perm filename PCROSS.PAS[PAS,SYS] blob
sn#474573 filedate 1979-09-07 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00018 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002 (*$T-,R64,D- *) (*TITLE PAGE*)
C00007 00003 (*DESCRIPTION AND HISTORY*)
C00014 00004 (*VALID SWITCHES*)
C00022 00005 (*GLOBAL DECLARATIONS*)
C00031 00006 VAR
C00047 00007 (*initialization:*) (*INITPROCEDURES,REINITIALIZE,GETCOUNTS,INITIALIZE*)
C00061 00008 (*ccl scanner:*) (*GETDIRECTIVES[SETSWITCH]*)
C00069 00009 (*PAGE CONTROL:*) (*trace,HEADER,NEWPAGE*)
C00074 00010 (*OUTPUT procs:*) (*block[ERROR,WRITELINE[USEDOTS]*)
C00089 00011 (*SCANNER:*) (*INSYMBOL[READBUFFER[READLINE],RESWORD,FINDNAME,INSERTCALL*)
C00104 00012 (*PARENTHESE,DOCOMMENT,SKIP_E_DIRECTORY*)
C00109 00013 (*] INSYMBOL*)
C00116 00014 (*PARSING OF DECLARATIONS:*) (*RECDEF[CASEDEF,PARENTHESE]*)
C00123 00015 (*PARSING OF STATEMENTS:*) (*STATEMENT[endedstats,compstat,casestat,loopstat,ifstat,labelstat,repeatstat]*)
C00141 00016 (*]BLOCK*)
C00151 00017 (*cross references:*) (*PRINT_XREF_LIST[CHECKPAGE,WRITEPROCNAME,WRITELINENR,DUMPCALL]*)
C00164 00018 (*MAIN PROGRAM*)
C00167 ENDMK
C⊗;
(*$T-,R64,D- *) (*TITLE PAGE*)
(*%SETt PCREF *)
(*%SETT SAIL *)
(*%setf trace *)
(********************************************************************************
*
* P C R O S S
* ***********
*
* PCROSS IS A ONE-SOURCE, TWO OBJECTS PROGRAM THAT CONTAINS A
* PRETTYPRINTER (PFORM) AND A CROSS-REFERENCER (PCREF) OF PASCAL
* SOURCE PROGRAMS. IT DERIVES FROM CROSS, WHICH COMES WITH THE
* HAMBURG COMPILER FOR DECSYSTEM-10 AND -20.
*
* TO SWITCH IT BACK AND FORTH BETWEEN THE TWO SOURCES CONTAINED IN
* IT, IT USES THE FEATURES OF pVERCH, DERIVED FROM CONDCOMP, CREATED
* BY RICHARD SITES AND IMPROVED BY PETER NYE AND ARMANDO RODRIGUEZ
* AT STANFORD ARTIFICIAL INTELLIGENCE LABORATORY, FOR THE PROJECT
* S-1.
*
*
*
* this program is in the public domain.
*
* part of the developement effort applied to this programs was performed
* as part of the effort in developement of programming languages and
* compilers AT STANFORD UNIVERSITY, UNDER A SUBCONTRACT FROM
* LAWRENCE LIVERMORE LABORATORY TO THE COMPUTER SCIENCE DEPARTMENT, PRINCIPAL
* INVESTIGARORS PROFS. FOREST BASKETT AND JOHN HENNESSY, CONTRACT NO. ...
* LLL PO9628303. THE S-1 WORK HARDWARE DEVELOPMENT HAS BEEN SUPPORTED BY
* THE DEPARTMENT OF THE NAVY VIA OFFICE OF NAVAL RESEARCH ORDER
* NUMBERS N00014-76-F-0023, N00014-77-F-0023, AND N00014-78-F-0023 TO THE
* UNIVERSITY OF CALIFORNIA LAWRENCE LIVERMORE LABORATORY (WHICH IS
* OPERATED FOR THE U. S. DEPARTMENT OF ENERGY UNDER CONTRACT NO.
* W-7405-ENG-48), FROM THE COMPUTATIONS GROUP OF THE STANFORD LINEAR
* ACCELERATOR CENTER (SUPPORTED BY THE U. S. DEPARTMENT OF ENERGY UNDER
* CONTRACT NO. EY-76-C-03-0515), AND FROM THE STANFORD ARTIFICIAL
* INTELLIGENCE LABORATORY (WHICH RECEIVES SUPPORT FROM THE DEFENSE
* ADVANCED RESEARCH PROJECTS AGENCY AND THE NATIONAL SCIENCE FOUNDATION).
*
(********************************************************************************
(*THINGS YET TO DO:
COMMENTS ON THE LEFT SIDE.
VERSION (% - \): out!
*)
(*DESCRIPTION AND HISTORY*)
(**********************************************************************
*
*
* p c r e f
* ---------
*
* CREATES A CROSS REFERENCE LISTING OF A PASCAL source PROGRAM.
*
* INPUT: PASCAL SOURCE FILE. (oldsource)
* OUTPUT: cross-reference listing. (crosslist)
*
* default input extension: none.
* default output extension: .lst
* default output file name: same as the input name, with extension .lst
*
* machine dependency: uses features supported by the pascal/passgo
* compilers for dec-10, dec-20, as implemented by armando r. rodriguez
* at stanford university.
*
* implementor: armando r. rodriguez
* p.o. box 5771
* stanford, ca 94305
* u.s.a.
*
* distributor: j. q. johnson
* lots computer facility
* stanford university
* stanford, ca 94305
* u.s.a.
*
* FROM AN ORIGINAL CROSS-REFERENCE PROCESSOR WRITTEN BY
* MANUEL MALL, UNIVERSITY OF HAMBURG (1974) and distributed
* with the hamburg compiler for dec-10, dec-20.
*
(**********************************************************************
(**********************************************************************
*
*
* p f o r m
* ---------
*
* reformats (prettyprints) A PASCAL source PROGRAM.
*
* INPUT: PASCAL SOURCE FILE. (oldsource)
* OUTPUT: reformatted source file. (newsource)
*
* default input extension: none.
* default output extension: .new
* default output file name: same as the input name, with extension .new
*
* machine dependency: uses features supported by the pascal/passgo
* compilers for dec-10, dec-20, as implemented by armando r. rodriguez
* at stanford university.
*
* implementor: armando r. rodriguez
* p.o. box 5771
* stanford, ca 94305
* u.s.a.
*
* distributor: j. q. johnson
* lots computer facility
* stanford university
* stanford, ca 94305
* u.s.a.
*
* FROM AN ORIGINAL CROSS-REFERENCE PROCESSOR WRITTEN BY
* MANUEL MALL, UNIVERSITY OF HAMBURG (1974) and distributed
* with the hamburg compiler for dec-10, dec-20 computers, by decus.
*
(**********************************************************************
(**********************************************************************
*
* JUL-79. ARMANDO R. RODRIGUEZ.
* + SEPARATE IT INTO PFORM AND PCREF
* + ADAPT IT FOR THE LINEPRINTER AT SAIL.
* + IMPROVE THE IMPLEMENTATION OF STATEMENT COUNTS.
* + FIX BUGS.
* + SEPARATE IT INTO PCREF AND PFORM.
*
* MAR-79. ARMANDO R. RODRIGUEZ
* + IMPLEMENT STATEMENT COUNTS.
*
* DEC-78. ARMANDO R. RODRIGUEZ (STANFORD)
* + SPEED UP AND CLEANNING OF THE CODE.
* + FIX SMALL BUGS.
*
* JUL-78. ARMANDO R. RODRIGUEZ (STANFORD).
* + IMPROVE THE CROSS REFERENCE LISTING.
* + LISTING OF PROC-FUNC CALL NESTING.
* + REPORT THE LINE NUMBERS OF BEGIN AND END OF BODY OF PROCEDURES.
*
* MAR-78. ARMANDO R. RODRIGUEZ (STANFORD).
* + A NEW SET OF SWITCH OPTIONS.
* + SOME NEW ERRORS ARE REPORTED.
*
* DATE UNKNOWN. LARRY PAULSON (STANFORD).
* + MAKE THE FILES OF TYPE TEXT
* + NOT AS MANY FORCED NEWLINES.
* + THE REPORT ON PROCEDURE CALLS WAS CANCELLED.
*
* THINGS TO BE FIXED, OR DOCUMENTED:
* PCREF:
* + IF THERE ARE TWO PROCS WITH ONE NAME, IT MIXES THEM.
* + IF A PROC NAME IS USED AS A VAR LATER, IT WILL BE SEEN
* AS A PROC FOR CALL-NESTING.
* + MAKE IT SMART ENOUGH TO AVOID CREATING STRUCTURES
* THAT WON'T BE USED, WHEN CROSS IS NOT 15.
*
*
(**********************************************************************)
(*VALID SWITCHES*)
(*---------------------------------------------------------------------
!
! FOR PCREF,
! VALID SWITCHES ARE: BRACKETS INDICATE OPTIONAL.
! <N> STANDS FOR AN INTEGER NUMBER.
! (DEFAULTS IN PARENS ARE AT SAIL) <L> STANDS FOR A LETTER.
!
! SWITCH MEANING DEFAULT.
!
! FILES.
! /CROSS[:<N>] WRITTING OF THE CROSSLIST FILE. ON,15
! <N> IS THE SUM OF:
! 1 SOURCE PROGRAM LISTING
! 2 LISTING OF IDENTIFIERS
! 4 LISTING OF PROC-FUNC
! DECLARATION NESTING.
! 8 LISTING OF PROC-FUNC CALL NESTING.
! /VERSION:<N> BEHAVE AS IF CONDITIONALLY COMPILING %<N>
! COMMENTS. -1
!
! PAGE AND LINE FORMAT
! /WIDTH:<N> MAXIMUM LINE LENGTH IN CROSSLIST 132 (120)
! /INDENT:<N> INDENTATION BETWEEN LEVELS. 4
! /INCREMENT:<N> LINE NUMBER INCREMENT 100
! /[NO]DOTS PUT AS A GUIDE A DOTTED LINE AT THE LEFT
! MARGIN EVERY FIFTH LINE ON
! /[NO]HEAD BREAK THE FILE IN PAGES WITH HEADERS FOR PRINT ON
! /LINES:<N> NUMBER OF LINES PER PAGE 57 (51)
!
! STATEMENT FORMAT
! /BEGIN:[-]<N> IF THE [-] IS NOT THERE, THE CONTENTS OF A
! BEGIN..END BLOCK IS INDENTED N SPACES FURTHER.
! IF IT IS THERE, THE BLOCK WILL NOT BE INDENTED,
! BUT THE BEGIN AND END STATEMENTS WILL BE
! EXDENTED N SPACES. 0
! /[NO]FORCE FORCES NEWLINE IN STANDARD PLACES. (BEFORE AND
! AFTER BEGIN, END, THEN, ELSE, REPEAT, ETC.) OFF
!
! UPPER AND LOWER CASE
! NOTE: THE POSSIBLE VALUES FOR <L> ARE:
! U MEANS UPPER CASE
! L MEANS LOWER CASE.
!
! /RES:<L> CASE USED FOR RESERVED WORDS. U
! /NONRES:<L> SAME FOR NON-RESERVED WORDS. L
! /COMM:<L> SAME FOR COMMENTS. L (U)
! /STR:<L> SAME FOR STRINGS. U
! /CASE:<L> RESETS ALL THE DEFAULTS TO <L>. OFF
!
!
! /[NO]DEBUG CREATE A FILE PCREF.BUG WITH THE COUNTS THAT
! WHERE NOT INCLUDED IN THE LISTING (PROFILE) OFF
!
!--------
!
! NOTE: IF A FILE .KNT IS FOUND, THE STATEMENT COUNTS FROM
! PROFILING THE PROGRAM WILL BE INSERTED, AND THE
! DEFAULT OF THE NEXT SWITCHES WILL CHANGE:
!
! /CROSS 1
! /FORCE ON
!
+--------------------------------------------------------------------*)
(*---------------------------------------------------------------------
!
! FOR PFORM,
! VALID SWITCHES ARE: BRACKETS INDICATE OPTIONAL.
! <N> STANDS FOR AN INTEGER NUMBER.
! (DEFAULTS IN PARENS ARE AT SAIL) <L> STANDS FOR A LETTER.
!
! SWITCH MEANING DEFAULT.
!
! FILES.
! /VERSION:<N> BEHAVE AS IF CONDITIONALLY COMPILING %<N>
! COMMENTS. -1
!
! PAGE AND LINE FORMAT
! /INDENT:<N> INDENTATION BETWEEN LEVELS. 4,3 (LOTS,SAIL)
!
! STATEMENT FORMAT
! /BEGIN:[-]<N> IF THE [-] IS NOT THERE, THE CONTENTS OF A
! BEGIN..END BLOCK IS INDENTED N SPACES FURTHER.
! IF IT IS THERE, THE BLOCK WILL NOT BE INDENTED,
! BUT THE BEGIN AND END STATEMENTS WILL BE
! EXDENTED N SPACES. 0
! /[NO]FORCE FORCES NEWLINE IN STANDARD PLACES. (BEFORE AND
! AFTER BEGIN, END, THEN, ELSE, REPEAT, ETC.) OFF
!
! UPPER AND LOWER CASE
! NOTE: THE POSSIBLE VALUES FOR <L> ARE:
! U MEANS UPPER CASE
! L MEANS LOWER CASE.
!
! /RES:<L> CASE USED FOR RESERVED WORDS. U
! /NONRES:<L> SAME FOR NON-RESERVED WORDS. L
! /COMM:<L> SAME FOR COMMENTS. L (U)
! /STR:<L> SAME FOR STRINGS. U
! /CASE:<L> RESETS ALL THE DEFAULTS TO <L>. OFF
!
+--------------------------------------------------------------------*)
(*GLOBAL DECLARATIONS*)
(*%IFT PCREF *)
PROGRAM PCREF;
(*%else pcref (IFF) *)
%\
%PROGRAM pform ;\
%\
(*%ENDC PCREF (ELSE) (IFF) *)
CONST
(*%IFT PCREF *)
(*%IFT SAIL *)
VERSION = 'PCREF/SAIL 1.0 10-JUL-79';
(*%ELSE SAIL (IFF) *)
% VERSION = 'PCREF/LOTS 1.0 10-JUL-79';\
(*%ENDC SAIL (ELSE) (IFF) *)
(*%ELSE PCREF (IFF) *)
(*%IFT SAIL *)
% version = 'PFORM/SAIL 1.0 10-JUL-79';\
(*%ELSE SAIL (IFF) *)
% VERSION = 'PFORM/LOTS 1.0 10-JUL-79';\
(*%ENDC SAIL (ELSE) (IFF) *)
(*%ENDC PCREF (ELSE) (IFF) *)
verlength = 10;
backslash = '\';
linsize = 600; (*maximum size of an input line*)
linsizplus2 = 602; (*linsize + 2*)
ht = 11B; (*ASCII TAB*)
blanks = ' '; (*FOR EDITING PURPOSES*)
(*%IFT SAIL *)
linnumsize = 3;
(*%ELSE SAIL (IFF) *)
% LINNUMSIZE = 5;\
(*%ENDC SAIL (ELSE) (IFF) *)
(*%IFT PCREF *)
COUNTERSIZE = 8; (*FIELD SIZE FOR THE STATEMENT COUNT VALUE*)
MAX_LINE_COUNT = 7777B; (*LIMIT OF LINES/EDIT-PAGE*)
MAX_PAGE_COUNT = 77B; (*LIMIT OF EDIT-PAGES*)
(* MAX_LINE_COUNT AND MAX_PAGE_COUNT SHOULD NOT NEED MORE THAN 18 BITS TOTAL*)
(*%IFT SAIL *)
STDMAXLINE = 51;
MAXCROSSCH = 120;
MARGIN = 14;
DOTS = ' . . . + . . . + . . . + . . . + . . . + . . . + . . . + . . . + . . . + . . . +';
(*%ELSE SAIL (IFF) *)
% STDMAXLINE = 57; (*MAXIMUM NUMBER OF LINES PER PAGE, IGNORING HEADER*)\
% MAXCROSSCH = 132; \
% MARGIN = 16; \
% DOTS = ' . . . + . . . + . . . + . . . + . . . + . . . + . . . +';\
(*%ENDC SAIL (ELSE) (IFF) *)
(*%ENDC PCREF *)
TYPE
pack6 = PACKED ARRAY[1..6] OF char;
pack9 = PACKED ARRAY[1..9] OF char;
pack15 = PACKED ARRAY[1..15] OF char;
errkinds = (begerrinblkstr,missgend,missgthen,missgof,missgexit,
missgrpar,missgquote,missgmain,missgpoint,linetoolong,
missgrbrack,missguntil);
symbol = (labelsy,constsy,typesy,varsy,programsy, (*DECSYM*)
functionsy,proceduresy,initprocsy, (*PROSYM*)
endsy,untilsy,elsesy,thensy,exitsy,ofsy,dosy,eobsy, (*ENDSYMBOLS*)
beginsy,casesy,loopsy,repeatsy,ifsy, (*BEGSYM*)
recordsy,forwardsy,gotosy,othersy,intconst,ident,strgconst,externsy,langsy,forsy,whilesy,
rbracket,rparent,semicolon,point,lparent,lbracket,colon,eqlsy,otherssy(*DELIMITER*));
(*%IFT PCREF *)
LINEPTRTY = ↑LINE;
LISTPTRTY = ↑LIST;
PROCSTRUCTY = ↑PROCSTRUC;
CALLEDTY = ↑CALLED;
LINENRTY = 0..MAX_LINE_COUNT;
PAGENRTY = 0..MAX_PAGE_COUNT;
LINE = PACKED RECORD
(*DESCRIPTION OF THE LINE NUMBER*)
LINENR : LINENRTY; (*LINE NUMBER*)
PAGENR : PAGENRTY; (*PAGE NUMBER*)
CONTLINK : LINEPTRTY; (*NEXT LINE NUMBER RECORD*)
DECLFLAG: CHAR; (*'D' IF DECLARATION, 'M' IF MULTIPLE OCCURRENCE,
BLANK OTHERWISE*)
END;
LIST = PACKED RECORD
(*DESCRIPTION OF IDENTIFIERS*)
NAME : ALFA; (*NAME OF THE IDENTIFIER*)
LLINK , (*LEFT SUCCESSOR IN TREE*)
RLINK : LISTPTRTY; (*RIGHT SUCCESSOR IN TREE*)
FIRST , (*POINTER TO FIRST LINE NUMBER RECORD*)
LAST : LINEPTRTY; (*POINTER TO LAST LINE NUMBER RECORD*)
EXTERNFLAG: CHAR; (*'E' IF EXTERNAL, 'F' IF FORWARD,
'D' IF TWO PROCS WITH THE SAME NAME, BLANK OTHERWISE*)
PROFUNFLAG : CHAR; (*'P' IF PROCEDURE NAME, 'F' IF FUNCTION, BLANK OTHERWISE*)
PROCDATA: PROCSTRUCTY;
END;
PROCSTRUC = PACKED RECORD
(*DESCRIPTION OF THE PROCEDURE NESTING*)
PROCNAME : LISTPTRTY; (*POINTER TO THE APPROPRIATE IDENTIFIER*)
NEXTPROC : PROCSTRUCTY; (*POINTER TO THE NEXT ELEMENT*)
LINENR, (*LINE NUMBER OF THE PROCEDURE DEFINITION*)
BEGLINE, (*LINE NUMBER OF THE BEGIN STATEMENT*)
ENDLINE: LINENRTY; (*LINENUMBER OF THE END STATEMENT*)
PAGENR , (*PAGE NUMBER OF THE PROCEDURE DEFINITION*)
BEGPAGE, (*PAGE NUMBER OF THE BEGIN STATEMENT*)
ENDPAGE, (*PAGE NUMBER OF THE END STATEMENT*)
PROCLEVEL: PAGENRTY; (*NESTING DEPTH OF THE PROCEDURE*)
FIRSTCALL: CALLEDTY; (*LIST OF PROCEDURES CALLED BY THIS ONE*)
PRINTED: BOOLEAN; (*TO AVOID LOOPS IN THE CALL-NEST LIST*)
END;
CALLED = PACKED RECORD
NEXTCALL : CALLEDTY;
WHOM : PROCSTRUCTY;
END;
(*%ELSE PCREF (IFF) *)
% linenrty = 0..maxint;\
% pagenrty = 0..maxint;\
(*%ENDC PCREF (ELSE) (IFF) *)
VAR
(*%ift trace *)
% (* (*debugging pcref/pform*)\
% (* (***********************)\
%\
% tracemargin: integer;\
(*%endc trace *)
(* (*INPUT CONTROL*)
(* (***************)
bufflen, (*LENGTH OF THE CURRENT LINE IN THE INPUT BUFFER*)
buffmark, (*LENGTH OF THE ALREADY PRINTED PART OF THE BUFFER*)
bufferptr, (*POINTER TO THE NEXT CHARACTER IN THE BUFFER*)
syleng: integer; (*LENGTH OF THE LAST READ IDENTIFIER OR LABEL*)
(* (*NESTING AND MATCHING CONTROL*)
(* (******************************)
level, (*NESTING DEPTH OF THE CURRENT PROCEDURE*)
variant_level, (*NESTING DEPTH OF VARIANTS*)
errcount: integer; (*COUNTS THE ERRORS ENCOUNTERED*)
(*%IFT PCREF *)
BMARKNR, (*NUMBER FOR MARKING OF 'BEGIN', 'LOOP' ETC.*)
EMARKNR, (*NUMBER FOR MARKING OF 'END', 'UNTIL' ETC.*)
BLOCKNR: INTEGER; (*COUNTS THE STATEMENTS 'BEGIN', 'CASE', 'LOOP', 'REPEAT', 'IF'*)
(*%ENDC PCREF *)
(* (*FORMATTING*)
(* (************)
increment, (*LINE NUMBER INCREMENT*)
indentbegin, (*INDENTATION AFTER A BEGIN*)
begexd, (*EXDENTATION FOR BEGIN-END PAIRS*)
feed, (*INDENTATION BY PROCEDURES AND BLOCKS*)
spaces, (*INDENTATION FOR THE CURRENT LINE*)
lastspaces, (*ONE-TIME OVERRIDING VALUE FOR SPACES*)
goodversion, (*KEEPS THE VALUE OF THE VERSION OPTION*)
pagecnt, (*COUNTS THE FILE PAGES*)
maxinc, (*GREATEST ALLOWABLE LINE NUMBER*)
maxch, (*MAXIMUM LENGTH OF SOURCE LINE IN CROSSLIST*)
line500, (*TO GIVE A TTY MESSAGE EVERY 500 LINES*)
linecnt : integer; (*COUNTS THE LINES PER FILE PAGE*)
tabs: ARRAY [1:17] OF ascii; (*A STRING OF TABS FOR FORMATTING*)
lower : ARRAY [ascii] OF ascii; (*TO MAP UPPER TO LOWER CASE IF DESIRED*)
(*%IFT PCREF *)
COUNTLINE, (*NEXT LINE FOR STATEMENT COUNTER*)
COUNTPAGE, (*PAGE OF NEXT LINE FOR STATEMENT COUNTER*)
COUNTTIMES, (*STATEMENT COUNT OF COUNTLINE/COUNTPAGE*)
MAXCOUNTTIMES, (*COUNT OF THE LINE WITH HIGHER COUNTTIMES*)
MAXCOUNTLINE, (*LINE FOR MAXCOUNTTIMES*)
MAXCOUNTPAGE, (*PAGE FOR MAXCOUNTTIMES*)
PAGECNT2, (*COUNTS THE PRINT PAGES PER FILE PAGE*)
MAXLINE, (*NUMBER OF LINES PER PAGE*)
REALLINCNT, (*COUNTS THE LINES PER PRINT PAGE*)
SOURCELINE, (*TO MATCH SOS LINES*)
SOURCEPAGE: INTEGER;
PROCSTRUCDATA : RECORD
(*NEXT PROCEDURE TO BE PUT IN NESTING LIST*)
EXISTS : BOOLEAN;
ITEM : PROCSTRUC;
END;
(*%ENDC PCREF *)
(* (*SCANNING*)
(* (**********)
buffer : ARRAY [-1..linsizplus2] OF ascii; (*INPUT BUFFER*)
(* BUFFER HAS 2 EXTRA POSITIONS ON THE LEFT AND ONE ON THE RIGHT*)
linenb : PACKED ARRAY [1..5] OF char; (*SOS-LINE NUMBER*)
prog_name: alfa; (*NAME OF CURRENT PROGRAM*)
sy : alfa; (*LAST SYMBOL READ*)
syty : symbol; (*TYPE OF THE LAST SYMBOL READ*)
(*%IFT PCREF *)
CURPROCNAME, (*NAME OF THE CURRENT PROCEDURE/FUNCTION, FOR THE HEADER*)
DATE_TEXT,TIME_TEXT: ALFA; (*HEADING DATE AND TIME*)
MARKSYTY, (*TYPE OF THE SYMBOL BEFORE THE LAST IF*)
PREVSYTY: SYMBOL; (*TYPE OF THE PREVIOUS SYMBOL*)
(*%ENDC PCREF *)
(* (*VERSION SYSTEM*)
(* (****************)
incondcomp: boolean;
(* (*SWITCHES*)
(* (**********)
elseifing, (*set if the sequence else if should stay in one line*)
debugging, (*SET IF THE UNPRINTED COUNTS ARE TO BE REPORTED*)
forcing, (*SET IF THEN, ELSE, DO, REPEAT WILL FORCE NEWLINE*)
rescase, (*SET IF RESERVED WORDS WILL UPSHIFT*)
nonrcase, (*SET IF NONRESERVED WORDS WILL UPSHIFT*)
comcase, (*SET IF COMMENTS WILL UPSHIFT*)
strcase, (*SET IF STRINGS WILL UPSHIFT*)
thendo, (*SET WHENEVER 'SPACES := SPACES+DOFEED' IS EXECUTED*)
anyversion: boolean; (*SET IF GOODVERSION > 9*)
(*%IFT PCREF *)
CROSSING, (*SET IF THE CROSSLIST FILE IS BEING WRITEN*)
REFING, (*SET IF THE REFERENCES WILL BE PRINTED*)
DECNESTING, (*SET IF THE PRO-FUNC DECLARATION LISTING WILL BE PRINTED*)
CALLNESTING, (*SET IF THE PRO-FUNC CALL NESTING WILL BE PRINTED*)
DOTTING, (*SET IF DOTED LINES WILL BE PRINTED AT LEFT MARGIN*)
COUNTING, (*SET IF A .KNT EXISTS, FOR STATEMENT COUNTS*)
HEADING: BOOLEAN; (*SET IF THE LISTING PAGES TAKE HEADERS*)
(*%ENDC PCREF *)
(* (*OTHER CONTROLS*)
(* (****************)
notokenyet, (*set in each line until the first token is scanned*)
elsehere, (*set while an else token is to be printed*)
fwddecl, (*SET TRUE BY BLOCK AFTER 'FORWARD', 'EXTERN'*)
oldspaces, (*SET WHEN LASTSPACES SHOULD BE USED*)
eoline, (*SET AT END ON INPUT LINE*)
programpresent, (*SET AFTER PROGRAM ENCOUNTERED*)
nobody, (*SET IF NO MAIN BODY IS FOUND*)
firstpage, (*TRUE BEFORE WRITTING ANYTHING*)
eob : boolean; (*EOF-FLAG*)
errmsg : PACKED ARRAY[errkinds,1..40] OF char; (*ERROR MESSAGES*)
ch : ascii; (*LAST READ CHARACTER*)
(*%IFT SAIL *)
diring, (*set if the e-directory should be printed*)
skipping: boolean; (*SET WHILE SKIPPING THE E-DIRECTORY*)
(*%ENDC SAIL *)
(*%IFT PCREF *)
nocountyet, (*SET WHEN COUNTING, FORCING, AND AN ELSE IS HERE*)
GOTOINLINE, (*SET IF A HORRENDOUS GOTO STATEMENT IN THIS LINE*)
DECLARING, (*SET WHILE PARSING DECLARATIONS*)
STMTPART: BOOLEAN; (*SET IF PROCESSING THE STATEMENT PART*)
BMARKTEXT, (*CHARACTER FOR MARKING OF 'BEGIN' ETC.*)
EMARKTEXT: CHAR; (*CHARACTER FOR MARKING OF 'END' ETC.*)
(*%ENDC PCREF *)
(* (*SETS*)
(* (******)
delsy : ARRAY [' '..'_'] OF symbol; (*TYPE ARRAY FOR DELIMITER CHARACTERS*)
resnum: ARRAY['A'..'['] OF integer; (*INDEX OF THE FIRST KEYWORD BEGINNING WITH THE INDEXED LETTER*)
reslist : ARRAY [1..46] OF alfa; (*LIST OF THE RESERVED WORDS*)
ressy : ARRAY [1..46] OF symbol; (*TYPE ARRAY OF THE RESERVED WORDS*)
alphanum, (*CHARACTERS FROM 0..9 AND A..Z*)
digits : SET OF char; (*CHARACTERS FROM 0..9*)
openblocksym, (*SYMBOLS AFTER WHICH A BASIC BLOCK STARTS*)
relevantsym, (*START SYMBOLS FOR STATEMENTS AND PROCEDURES*)
prosym, (*ALL SYMBOLS WHICH BEGIN A PROCEDURE*)
decsym, (*ALL SYMBOLS WHICH BEGIN DECLARATIONS*)
begsym, (*ALL SYMBOLS WHICH BEGIN COMPOUND STATEMENTS*)
endsym : SET OF symbol; (*ALL SYMBOLS WHICH TERMINATE STATEMENTS OR PROCEDURES*)
(* (*POINTERS AND FILES*)
(* (********************)
old_name: pack9; (*USED TO GET THE PARAMETER FILES*)
old_dev: pack6;
old_prot,old_ppn: integer;
programname,oldfileid: alfa;
oldsource: text;
(*%IFF PCREF *)
% new_name: pack9;\
% new_dev: pack6;\
% new_prot,new_ppn: integer;\
% newfileid: alfa;\
% newsource: text;\
(*%ENDC PCREF *)
(*%IFT PCREF *)
LISTPTR, HEAPMARK : LISTPTRTY; (*POINTER INTO THE BINARY TREE OF THE IDENTIFIER*)
FIRSTNAME : ARRAY ['A'..'Z'] OF LISTPTRTY; (*POINTER TO THE ROOTS OF THE TREE*)
PROCSTRUCF, (*POINTER TO THE FIRST ELEMENT OF THE PROCEDURE CALLS LIST*)
PROCSTRUCL : PROCSTRUCTY; (*POINTER TO THE LAST ELEMENT OF THE PROCEDURE CALLS LIST*)
WORKCALL: CALLEDTY;
COUNTFILENAME, (*NAME OF THE STATEMENT COUNTS FILE*)
CROSS_NAME,LINK_NAME: PACK9;
LINK_DEVICE,CROSS_DEV:PACK6;
CROSS_PROT,CROSS_PPN: INTEGER;
CROSSFILEID: ALFA;
DEBUGFILE,
CROSSLIST: TEXT; (*FILES PROCESSED BY THIS PROGRAM*)
COUNTFILE: FILE OF INTEGER; (*FILE FOR STATEMENT COUNTS*)
(*%ENDC PCREF *)
(*initialization:*) (*INITPROCEDURES,REINITIALIZE,GETCOUNTS,INITIALIZE*)
INITPROCEDURE;
BEGIN (*CONSTANTS*)
diring := false;
elsehere := false;
elseifing := false;
eob := false;
indentbegin:=0;
begexd:=0;
goodversion := -1;
rescase:=true;
nonrcase:=false;
strcase:=true;
nobody := false;
anyversion := false;
oldfileid:='OLDSOURCE ';
(*%ift trace *)
% tracemargin := 0;\
(*%endc trace *)
(*%IFT SAIL *)
feed := 3;
comcase := true;
(*%ELSE SAIL (IFF) *)
% FEED:=4; \
% COMCASE:=FALSE; \
(*%ENDC SAIL (ELSE) (IFF) *)
(*%IFT PCREF *)
DEBUGGING := FALSE;
HEADING := TRUE;
CROSSING:=TRUE;
REFING:=FALSE;
DECNESTING:=FALSE;
CALLNESTING:=FALSE;
DOTTING:=TRUE;
CROSS_NAME:=' ';
PROGRAMNAME := 'PCREF ';
CROSSFILEID:='CROSSLIST ';
(*%IFT SAIL *)
INCREMENT := 1;
(*%ELSE SAIL (IFF) *)
% INCREMENT:=100; \
(*%ENDC SAIL (ELSE) (IFF) *)
(*%ELSE PCREF (IFF) *)
% new_name:=' ';\
% programname:='PFORM ';\
% newfileid:='NEWSOURCE ';\
(*%ENDC PCREF (ELSE) (IFF) *)
END (*CONSTANTS*);
INITPROCEDURE;
BEGIN (*RESERVED WORDS*)
resnum['A'] := 1; resnum['B'] := 3; resnum['C'] := 4;
resnum['D'] := 6; resnum['E'] := 9; resnum['F'] := 13;
resnum['G'] := 18; resnum['H'] := 19; resnum['I'] := 19;
resnum['J'] := 22; resnum['K'] := 22; resnum['L'] := 22;
resnum['M'] := 24; resnum['N'] := 25; resnum['O'] := 27;
resnum['P'] := 30; resnum['Q'] := 33; resnum['R'] := 33;
resnum['S'] := 35; resnum['T'] := 36; resnum['U'] := 39;
resnum['V'] := 40; resnum['W'] := 41; resnum['X'] := 43;
resnum['Y'] := 43; resnum['Z'] := 43; resnum['['] := 43;
reslist[ 1] :='AND '; ressy [ 1] := othersy;
reslist[ 2] :='ARRAY '; ressy [ 2] := othersy;
reslist[ 3] :='BEGIN '; ressy [ 3] := beginsy;
reslist[ 4] :='CASE '; ressy [ 4] := casesy;
reslist[ 5] :='CONST '; ressy [ 5] := constsy;
reslist[ 6] :='DO '; ressy [ 6] := dosy;
reslist[ 7] :='DIV '; ressy [ 7] := othersy;
reslist[ 8] :='DOWNTO '; ressy [ 8] := othersy;
reslist[ 9] :='END '; ressy [ 9] := endsy;
reslist[10] :='ELSE '; ressy [10] := elsesy;
reslist[11] :='EXIT '; ressy [11] := exitsy;
reslist[12] :='EXTERN '; ressy [12] := externsy;
reslist[13] :='FOR '; ressy [13] := forsy;
reslist[14] :='FILE '; ressy [14] := othersy;
reslist[15] :='FORWARD '; ressy [15] := forwardsy;
reslist[16] :='FUNCTION '; ressy [16] := functionsy;
reslist[17] :='FORTRAN '; ressy [17] := externsy;
reslist[18] :='GOTO '; ressy [18] := gotosy;
reslist[19] :='IF '; ressy [19] := ifsy;
reslist[20] :='IN '; ressy [20] := othersy;
reslist[21] :='INITPROCED'; ressy [21] := initprocsy;
reslist[22] :='LOOP '; ressy [22] := loopsy;
reslist[23] :='LABEL '; ressy [23] := labelsy;
reslist[24] :='MOD '; ressy [24] := othersy;
reslist[25] :='NOT '; ressy [25] := othersy;
reslist[26] :='NIL '; ressy [26] := othersy;
reslist[27] :='OR '; ressy [27] := othersy;
reslist[28] :='OF '; ressy [28] := ofsy;
reslist[29] :='OTHERS '; ressy [29] := otherssy;
reslist[30] :='PACKED '; ressy [30] := othersy;
reslist[31] :='PROCEDURE '; ressy [31] := proceduresy;
reslist[32] :='PROGRAM '; ressy [32] := programsy;
reslist[33] :='RECORD '; ressy [33] := recordsy;
reslist[34] :='REPEAT '; ressy [34] := repeatsy;
reslist[35] :='SET '; ressy [35] := othersy;
reslist[36] :='THEN '; ressy [36] := thensy;
reslist[37] :='TO '; ressy [37] := othersy;
reslist[38] :='TYPE '; ressy [38] := typesy;
reslist[39] :='UNTIL '; ressy [39] := untilsy;
reslist[40] :='VAR '; ressy [40] := varsy;
reslist[41] :='WHILE '; ressy [41] := whilesy;
reslist[42] :='WITH '; ressy [42] := othersy;
END (*RESERVED WORDS*);
INITPROCEDURE;
BEGIN (*SETS*)
digits := ['0'..'9'];
alphanum := ['0'..'9','A'..'Z'] (*LETTERS OR DIGITS*);
decsym := [labelsy,constsy,typesy,varsy,programsy];
prosym := [functionsy..initprocsy];
endsym := [functionsy..eobsy]; (*PROSYM OR ENDSYMBOLS*)
begsym := [beginsy..ifsy];
relevantsym := [labelsy..initprocsy (*DECSYM OR PROSYM*),beginsy,forwardsy,externsy,eobsy];
openblocksym := [thensy,elsesy,dosy,loopsy,repeatsy,intconst,colon,exitsy]
END (*SETS*);
INITPROCEDURE;
BEGIN (*ERROR MESSAGES*)
errmsg[begerrinblkstr] := 'ERROR IN BLOCK STRUCTURE: BEGIN EXPECTED';
errmsg[missgend ] := 'MISSING ''END'' STATEMENT NUMBER ';
errmsg[missgthen ] := 'MISSING ''THEN'' FOR ''IF'' NUMBER ';
errmsg[missgof ] := 'MISSING ''OF'' IN ''CASE'' NUMBER ';
errmsg[missgexit ] := 'MISSING ''EXIT'' IN ''LOOP'' NUMBER ';
errmsg[missgrpar ] := 'MISSING RIGHT PARENTHESIS ';
errmsg[missgquote ] := 'MISSING CLOSING QUOTE ON THIS LINE ';
errmsg[missgmain ] := 'WARNING: THIS FILE HAS NO MAIN BODY ';
errmsg[missgpoint ] := 'MISSING CLOSING POINT AT END OF PROGRAM.';
errmsg[linetoolong ] := 'LINE TOO LONG. I''M GONNA GET CONFUSED. ';
errmsg[missguntil ] := 'MISSING ''UNTIL'' FOR ''REPEAT'' NUMBER ';
errmsg[missgrbrack ] := 'MISSING RIGHT BRACKET ';
END (*ERROR MESSAGES*);
PROCEDURE reinitialize;
VAR
lch: char;
BEGIN (*REINITIALIZE*)
bufflen := 0; buffmark := 0; errcount := 0;
bufferptr := 2; variant_level := 0; level := 0;
line500 := 0; linecnt :=0; pagecnt := 1;
eoline := true; firstpage := true; notokenyet := true;
programpresent := false; oldspaces := false; incondcomp := false;
sy := blanks; prog_name := blanks;
(*%IFT SAIL *)
skipping := false;
(*%ENDC SAIL *)
(*%IFT PCREF *)
NEW(HEAPMARK); (*THE HEAP IS DEALLOCATED AFTER EACH PROGRAM*)
WORKCALL := NIL;
PAGECNT2 := 0; SOURCEPAGE := 1; SOURCELINE := 0;
MAXCOUNTPAGE := 0; MAXCOUNTLINE := 0; MAXCOUNTTIMES := 0;
BLOCKNR := 0; REALLINCNT:= MAXLINE;
DECLARING := TRUE; GOTOINLINE := FALSE; nocountyet := FALSE;
PROCSTRUCDATA.EXISTS := FALSE;
BMARKTEXT := ' '; EMARKTEXT := ' '; CH := ' ';
DATE(DATE_TEXT); TIME(TIME_TEXT);
FOR LCH := 'A' TO 'Z' DO
FIRSTNAME [LCH] := NIL;
NEW (FIRSTNAME['M']);
LISTPTR := FIRSTNAME ['M'];
WITH FIRSTNAME ['M']↑ DO
BEGIN
NAME := 'MAIN PROGM';
LLINK := NIL;
RLINK := NIL;
PROFUNFLAG := 'M';
NEW (FIRST);
LAST := FIRST;
WITH LAST↑ DO
BEGIN
LINENR := 1;
PAGENR:=1;
CONTLINK := NIL;
END;
END;
NEW (PROCSTRUCF);
WITH PROCSTRUCF↑ DO
BEGIN
PROCNAME := FIRSTNAME ['M'];
NEXTPROC := NIL;
LINENR := 1;
PAGENR:=1;
PROCLEVEL:= 0;
FIRSTCALL := NIL;
END;
PROCSTRUCL := PROCSTRUCF;
CURPROCNAME := 'MAIN PROGM';
(*%ENDC PCREF *)
END (*REINITIALIZE*);
(*%IFT PCREF *)
PROCEDURE GETCOUNTS;
BEGIN
IF EOF(COUNTFILE) THEN
BEGIN
COUNTLINE := 99999;
COUNTPAGE := 99999;
END
ELSE
BEGIN
COUNTPAGE := COUNTFILE↑;
GET(COUNTFILE);
COUNTLINE := COUNTFILE↑;
GET(COUNTFILE);
COUNTTIMES := COUNTFILE↑;
GET(COUNTFILE);
END;
END (*GETCOUNTS*);
(*%ENDC PCREF *)
PROCEDURE initialize;
VAR
i: integer;
BEGIN (*INITIALIZE*)
FOR ch := ' ' TO '_' DO
delsy [ch] := othersy;
delsy ['('] := lparent;
delsy [')'] := rparent;
delsy ['['] := lbracket;
delsy [']'] := rbracket;
delsy [';'] := semicolon;
delsy ['.'] := point;
delsy [':'] := colon;
delsy ['='] := eqlsy;
FOR i := -1 TO 201 DO
buffer [i] := ' ';
FOR i := 1 TO 17 DO
tabs [i] := chr (ht);
FOR ch := nul TO '@' DO
lower[ch] := ch;
FOR ch := 'A' TO 'Z' DO
lower[ch] := chr (ord(ch) + 40B);
FOR ch := '[' TO del DO
lower[ch] := ch;
reinitialize;
END (*INITIALIZE*);
(*ccl scanner:*) (*GETDIRECTIVES[SETSWITCH]*)
PROCEDURE getdirectives;
(* CHECKS THE PRESENCE OF SWITCHES WITH THE FILE NAMES. *)
VAR
brkchar: char;
try: integer;
fromtmp: boolean;
PROCEDURE setswitch(opt:alfa;VAR switch:boolean);
VAR
i: integer;
BEGIN (*SETSWITCH*)
getoption(opt,i);
IF i=ord('L') THEN
switch:=false
ELSE
IF i=ord('U') THEN
switch:=true;
END (*SETSWITCH*);
BEGIN (*GETDIRECTIVES*)
(*%IFT SAIL *) (*OPEN OLDSOURCE*)
askfilename(old_name,old_prot,old_ppn,old_dev,oldfileid,programname,false,fromtmp,brkchar);
startfile(oldsource,old_name,old_prot,old_ppn,old_dev,true,oldfileid,'PAS');
(*%ELSE SAIL (IFF) *)
% GETPARAMETER(OLDSOURCE,OLDFILEID,PROGRAMNAME,TRUE);\
(*%ENDC SAIL (ELSE) (IFF) *)
getstatus(oldsource,old_name,old_prot,old_ppn,old_dev);
(*%IFT PCREF *) (*OPEN CROSSLIST AND COUNTFILE*)
ASKFILENAME(CROSS_NAME,CROSS_PROT,CROSS_PPN,CROSS_DEV,CROSSFILEID,PROGRAMNAME,FALSE,FROMTMP,BRKCHAR);
IF (CROSS_NAME = ' ') AND (CROSS_DEV = 'DSK ') THEN
BEGIN
CROSS_NAME := OLD_NAME;
CROSS_NAME[7]:='L';
CROSS_NAME[8]:='S';
CROSS_NAME[9]:='T';
END;
STARTFILE(CROSSLIST,CROSS_NAME,CROSS_PROT,CROSS_PPN,CROSS_DEV,FALSE,CROSSFILEID,' ');
COUNTFILENAME := OLD_NAME;
COUNTFILENAME[7] := 'K';
COUNTFILENAME[8] := 'N';
COUNTFILENAME[9] := 'T';
RESET(COUNTFILE,COUNTFILENAME);
IF EOF(COUNTFILE) THEN
RESET (COUNTFILE,COUNTFILENAME,OLD_PROT,OLD_PPN,OLD_DEV);
COUNTING := NOT EOF(COUNTFILE);
IF COUNTING THEN
BEGIN
FORCING := TRUE;
(*%IFT SAIL *)
CALLNESTING := FALSE;
DECNESTING := FALSE;
REFING := FALSE;
(*%ENDC SAIL *)
GETCOUNTS;
END;
IF COUNTING THEN
BEGIN
WRITELN(TTY);
WRITELN(TTY,'I FOUND ',COUNTFILENAME:6,'.KNT: WILL DO STATEMENT COUNTS');
END;
BREAK(TTY);
(*%IFT SAIL *)
IF NOT COUNTING THEN
BEGIN
(*%ENDC SAIL *)
GETOPTION('CROSS ',TRY);
IF TRY = 0 THEN
TRY:=15;
CALLNESTING:=TRY > 7;
DECNESTING:=(TRY MOD 8) > 3;
REFING:= (TRY MOD 4) > 1;
CROSSING:=(TRY MOD 2) = 1;
(*%IFT SAIL *)
END;
(*%ENDC SAIL *)
(*%ELSE PCREF (IFF) *) (*OPEN NEWSOURCE*)
%\
% askfilename(new_name,new_prot,new_ppn,new_dev,newfileid,programname,false,fromtmp,brkchar);\
% IF (new_name = ' ') AND (new_dev = 'DSK ') THEN\
% BEGIN\
% getstatus(oldsource, new_name,old_prot,old_ppn,old_dev);\
% new_name[7]:='N';\
% new_name[8]:='E';\
% new_name[9]:='W';\
% END;\
% startfile(newsource,new_name,new_prot,new_ppn,new_dev,false,newfileid,' ');\
%\
(*%ENDC PCREF (ELSE) (IFF) *)
IF option ('VERSION ') THEN
BEGIN
getoption ('VERSION ',goodversion);
IF goodversion > 9 THEN
BEGIN
goodversion := -1;
anyversion := true;
END;
END;
IF option('INDENT ') THEN
BEGIN
getoption('INDENT ',feed);
IF feed < 0 THEN
feed:=4;
END;
IF option('BEGIN ') THEN
BEGIN
getoption('BEGIN ',indentbegin);
IF indentbegin < 0 THEN
BEGIN
begexd:=-indentbegin;
indentbegin:=0;
END;
END;
forcing:=forcing OR option('FORCE ');
elseifing := option ('elseif ');
IF option('CASE ') THEN
BEGIN
setswitch('CASE ',rescase);
nonrcase:=rescase;
comcase:=rescase;
strcase:=rescase;
END;
setswitch('RES ',rescase);
setswitch('NONRES ',nonrcase);
setswitch('COMM ',comcase);
setswitch('STR ',strcase);
(*%IFT sail *)
diring := option ('dir ');
(*%endc sail *)
(*%IFT PCREF *)
IF option('INCREMENT ') THEN
BEGIN
getoption('INCREMENT ',increment);
IF increment < 0 THEN
increment:= 100;
END;
DEBUGGING := OPTION ('DEBUG ');
IF DEBUGGING THEN
REWRITE(DEBUGFILE,'PCREF.BUG');
HEADING := NOT OPTION('NOHEAD ');
IF OPTION('LINES ') AND HEADING THEN
BEGIN
GETOPTION('LINES ',MAXLINE);
IF MAXLINE <= 0 THEN
MAXLINE := MAXINT;
END
ELSE
MAXLINE := STDMAXLINE;
IF OPTION('WIDTH ') THEN
GETOPTION('WIDTH ',MAXCH)
ELSE
MAXCH := MAXCROSSCH;
MAXCH := MAXCH - MARGIN;
DOTTING:=NOT OPTION('NODOTS ');
(*%ENDC PCREF *)
END (*GETDIRECTIVES*);
(*PAGE CONTROL:*) (*trace,HEADER,NEWPAGE*)
(*%ift trace *)
%procedure trace(name:pack15);\
% begin\
% if name[1] = 'o' then\
% tracemargin := tracemargin - 3;\
(*%IFT PCREF *)
% writeln(crosslist,dots:tracemargin,name);\
(*%ELSE PCREF (IFF) *)
% writeln(newsource,dots:tracemargin,name);\
(*%ENDC PCREF (ELSE) (IFF) *)
% if name[1] = 'i' then\
% tracemargin := tracemargin + 3;\
% end (*trace*);\
(*%endc trace *)
(*%IFT PCREF *)
PROCEDURE HEADER (NAME: ALFA);
(*PRINT TOP OF FORM AND HEADER ON LIST OUTPUT*)
BEGIN (*HEADER*)
(*%ift trace *)
%trace('in header ');\
(*%endc trace *)
if crossing then
begin
PAGECNT2 := PAGECNT2 + 1;
REALLINCNT := 0;
IF HEADING THEN
BEGIN
(*%IFT SAIL *)
IF NOT (FIRSTPAGE OR SKIPPING) THEN
PAGE(CROSSLIST);
WRITE(CROSSLIST,VERSION:26,' ':7,OLD_NAME:6,'.',OLD_NAME[7],OLD_NAME[8],OLD_NAME[9],
' [ ',PROG_NAME,' ] ', DATE_TEXT, ' ', TIME_TEXT);
WRITELN (CROSSLIST, 'PAGE ':13, PAGECNT:3, '-', PAGECNT2:2, NAME:15);
WRITELN(CROSSLIST);
END (*IF HEADING*)
else
if pagecnt2 = 1 then
IF NOT (FIRSTPAGE OR SKIPPING) THEN
PAGE(CROSSLIST);
FIRSTPAGE := FALSE;
(*%ELSE SAIL (IFF) *)
% IF FIRSTPAGE THEN\
% FIRSTPAGE := FALSE\
% ELSE\
% PAGE(CROSSLIST);\
% IF HEADING THEN\
% BEGIN\
% WRITE(CROSSLIST,VERSION:28,' ':10,OLD_NAME:6,'.',OLD_NAME[7],OLD_NAME[8],OLD_NAME[9],\
% ' [ ',PROG_NAME,' ]',' ':9, DATE_TEXT, ' ', TIME_TEXT);\
% WRITELN (CROSSLIST, 'PAGE ':15, PAGECNT:3, '-', PAGECNT2:2, NAME:15);\
% WRITELN(CROSSLIST);\
% END (*IF HEADING*);\
(*%ENDC SAIL (ELSE) (IFF) *)
end (*if crossing*);
(*%ift trace *)
%trace('out header ');\
(*%endc trace *)
END (*HEADER*);
(*%ENDC PCREF *)
PROCEDURE newpage;
BEGIN (*NEWPAGE*)
(*%ift trace *)
%trace('in newpage ');\
(*%endc trace *)
pagecnt := pagecnt + 1;
IF eoln (oldsource) THEN
readln(oldsource);
linecnt := 0;
line500 := 0;
IF prog_name <> blanks THEN
write(tty,pagecnt:3,'..');
break(tty);
(*%IFT PCREF *)
PAGECNT2 := 0;
HEADER (CURPROCNAME);
(*%ELSE PCREF (IFF) *)
(*%IFT SAIL *)
% IF NOT skipping THEN\
(*%ENDC SAIL *)
% IF firstpage THEN\
% firstpage := false\
% ELSE\
% page(newsource);\
(*%ENDC PCREF (ELSE) (IFF) *)
(*%ift trace *)
%trace('out newpage ');\
(*%endc trace *)
END (*NEWPAGE*);
(*OUTPUT procs:*) (*block[ERROR,WRITELINE[USEDOTS]*)
PROCEDURE block;
VAR
i: integer;
itisaproc : boolean; (*TRUE WHEN THE WORD PROCEDURE IS FOUND*)
lastprocname: alfa; (*IMPLICIT STACK OF PROCEDURE NAMES FOR THE HEADER*)
(*%IFT PCREF *)
CURPROC : LISTPTRTY; (*ZEIGER AUF DIE PROZEDUR IN DEREN ANWEISUNGSTEIL DAS PROGRAMM SICH BEFINDET*)
LOCPROCSTL: PROCSTRUCTY;
(*%ENDC PCREF *)
PROCEDURE error (errnr : errkinds);
BEGIN (*ERROR*)
errcount := errcount+1;
(*%IFT PCREF *)
REALLINCNT := REALLINCNT + 1; (*COUNT THE LINE FOR THE ERROR MESSAGE ON CROSSLIST*)
WRITE (CROSSLIST, ' ':17,' *??* ');
CASE ERRNR OF
BEGERRINBLKSTR: WRITE(CROSSLIST, SY, ERRMSG[BEGERRINBLKSTR]);
MISSGEND, MISSGTHEN, MISSGUNTIL,
MISSGEXIT : WRITE(CROSSLIST, ERRMSG[ERRNR],EMARKNR : 4);
OTHERS : WRITE(CROSSLIST, ERRMSG[ERRNR]);
END;
WRITELN(CROSSLIST,' *??*');
(*%ELSE PCREF (iff) *)
% write (newsource, '(*??* ');\
% CASE errnr OF\
% begerrinblkstr: write(newsource, sy, errmsg[begerrinblkstr]);\
% missgend, missgthen, missguntil,\
% missgexit : write(newsource, errmsg[errnr]);\
% OTHERS : write(newsource, errmsg[errnr]);\
% END;\
% writeln(newsource,' *??*)');\
(*%ENDC PCREF (ELSE) (IFF) *)
writeln(tty);
write (tty, 'ERROR AT ', linecnt*increment: linnumsize, '/', pagecnt:2,': ');
CASE errnr OF
begerrinblkstr: write(tty, sy, errmsg[begerrinblkstr]);
missgend, missgthen, missguntil,
missgexit :
(*%IFT PCREF *)
WRITE(TTY, ERRMSG[ERRNR],EMARKNR : 4);
(*%ELSE PCREF (IFF) *)
% write(tty, errmsg[errnr]);\
(*%ENDC PCREF (ELSE) (IFF) *)
OTHERS : write(tty, errmsg[errnr]);
END;
writeln(tty);
break (tty);
END (*ERROR*) ;
PROCEDURE writeline (position (*LETZTES ZU DRUCKENDES ZEICHEN IM PUFFER*): integer);
VAR
ladjust,
i, j, maxchar: integer; (*MARKIERT ERSTES ZU DRUCKENDES ZEICHEN*)
(*%IFT PCREF *)
PROCEDURE USEDOTS(LASTSPACES: INTEGER);
BEGIN (*USEDOTS*)
(*USE EITHER DOTS OR SPACES TO MAKE INDENTATION*)
IF LASTSPACES >= 0 THEN
IF DOTTING AND ((REALLINCNT MOD 5) = 0) THEN
WRITE(CROSSLIST,DOTS: LASTSPACES)
ELSE (*NO DOTS IN THIS LINE*)
BEGIN
LASTSPACES := LASTSPACES;
IF LASTSPACES > 7 THEN
LASTSPACES := LASTSPACES + 2 + LINNUMSIZE;
WRITE(CROSSLIST, TABS: LASTSPACES DIV 8, ' ': LASTSPACES MOD 8);
END;
IF COUNTING THEN (*IF MAKING STATEMENT COUNTS, PRINT THE COUNT*)
BEGIN
WHILE (SOURCEPAGE > COUNTPAGE) DO (*FIND THE COUNT FOR THIS LINE*)
BEGIN
IF DEBUGGING THEN
WRITELN(DEBUGFILE,COUNTLINE,COUNTPAGE,COUNTTIMES);
GETCOUNTS;
END;
IF SOURCEPAGE = COUNTPAGE THEN
WHILE SOURCELINE > COUNTLINE DO
BEGIN
IF DEBUGGING THEN
WRITELN(DEBUGFILE,COUNTLINE,COUNTPAGE,COUNTTIMES);
GETCOUNTS;
END;
IF (COUNTLINE = SOURCELINE) AND (COUNTPAGE = SOURCEPAGE) AND
NOT nocountyet THEN
BEGIN (*IF IT EXISTS, PRINT IT*)
WRITE(CROSSLIST,COUNTTIMES:COUNTERSIZE,'-+ ');
IF COUNTTIMES >= MAXCOUNTTIMES THEN
BEGIN
MAXCOUNTTIMES := COUNTTIMES;
MAXCOUNTLINE := SOURCELINE;
MAXCOUNTPAGE := SOURCEPAGE;
END;
GETCOUNTS;
END
ELSE (*NO COUNT HERE*) (*OTHERWISE, FILL THE SPACE*)
IF DOTTING AND ((REALLINCNT MOD 5) = 0) THEN
IF STMTPART THEN
WRITE(CROSSLIST,DOTS:COUNTERSIZE+1,'! ')
ELSE
WRITE(CROSSLIST,DOTS:COUNTERSIZE+7,' ')
ELSE
IF STMTPART THEN
WRITE(CROSSLIST,'!':COUNTERSIZE+2,' ':6)
ELSE
WRITE(CROSSLIST,' ':COUNTERSIZE+8);
END (*COUNTING*)
ELSE (*NOT COUNTING*)
WRITE(CROSSLIST,' ');
END (*USEDOTS*);
(*%ENDC PCREF *)
BEGIN (*WRITELINE*)
position := position - 2;
IF position > 0 THEN
BEGIN
i := buffmark + 1; (* 1. DISCARD BLANKS AT BOTH ENDS *)
WHILE (buffer [i] = ' ') AND (i <= position) DO
i := i + 1;
buffmark := position;
WHILE (buffer [position] = ' ') AND (i < position) DO
position := position - 1;
IF i <= position THEN (* 2. IF ANYTHING LEFT, WRITE IT. *)
BEGIN
IF NOT oldspaces THEN
lastspaces := spaces;
(*%IFT PCREF *)
if crossing then
begin
IF REALLINCNT >= MAXLINE THEN
HEADER (CURPROCNAME);
REALLINCNT := REALLINCNT + 1;
IF GOTOINLINE THEN (* 2.1.1. LEFT MARGIN *)
BEGIN
WRITE(CROSSLIST, '***GOTO***');
GOTOINLINE := FALSE;
BMARKTEXT:=' ';
EMARKTEXT:=' ';
END
ELSE
BEGIN
IF BMARKTEXT <> ' ' THEN
BEGIN
WRITE (CROSSLIST, BMARKTEXT, BMARKNR : 3, ' ');
BMARKTEXT := ' ';
END
ELSE
WRITE(CROSSLIST,' ');
IF EMARKTEXT <> ' ' THEN
BEGIN
WRITE (CROSSLIST,EMARKTEXT,EMARKNR : 3,' ');
EMARKTEXT := ' ';
END
ELSE
WRITE (CROSSLIST,' ');
END;
WRITE (CROSSLIST, LINECNT * INCREMENT : LINNUMSIZE); (* 2.1.2. LINENUMBER AND INDENTATION *)
USEDOTS(LASTSPACES);
MAXCHAR:=MAXCH+I-LASTSPACES-1;
IF COUNTING THEN
MAXCHAR := MAXCHAR - COUNTERSIZE+7;
FOR J := I TO POSITION DO (* 2.1.3. CONTENTS OF THE LINE *)
BEGIN
IF J > MAXCHAR THEN
BEGIN
WRITELN(CROSSLIST);
IF REALLINCNT = MAXLINE THEN
HEADER (BLANKS);
REALLINCNT:=REALLINCNT+1;
WRITE(CROSSLIST,' ':MARGIN);
LADJUST := MIN(20,POSITION-J+1);
IF MAXCH - LASTSPACES - FEED > LADJUST THEN
BEGIN
USEDOTS(LASTSPACES+FEED-1);
MAXCHAR:=MAXCH+J-LASTSPACES-feed;
END
ELSE
BEGIN
USEDOTS(MAXCH - LADJUST);
MAXCHAR := LADJUST + j - 1;
END;
END;
CROSSLIST↑ := BUFFER[J];
PUT(CROSSLIST);
END;
WRITELN(CROSSLIST);
end;
(*%ELSE PCREF (IFF) *)
%\
% write (newsource, tabs:lastspaces DIV 8, ' ':lastspaces MOD 8);\
% FOR j := i TO position DO\
% BEGIN\
% newsource↑ := buffer[j];\
% put(newsource);\
% END;\
% writeln(newsource);\
%\
(*%ENDC PCREF (ELSE) (IFF) *)
WHILE (buffmark < bufflen) AND (buffer[buffmark] = ' ') DO (* 3. RESET POINTERS AND FLAGS *)
buffmark := buffmark + 1;
IF buffmark < bufflen THEN
IF buffer[buffmark - 1] = ' ' THEN
buffmark := buffmark - 1
ELSE
ELSE
IF (linenb = ' ') THEN
BEGIN
newpage;
(*%IFT PCREF *)
SOURCEPAGE := SOURCEPAGE + 1;
SOURCELINE := 0;
(*%ENDC PCREF *)
END
ELSE
IF (linecnt >= maxinc) THEN
newpage;
END (* IF I <= POSITION *);
END (* IF POSITION > 0 *);
lastspaces := spaces;
oldspaces := false;
thendo := false;
elsehere := false;
(*%IFT PCREF *)
nocountyet := FALSE;
(*%ENDC PCREF *)
END (*WRITELINE*) ;
(*SCANNER:*) (*INSYMBOL[READBUFFER[READLINE],RESWORD,FINDNAME,INSERTCALL*)
PROCEDURE insymbol ;
LABEL
1,111;
VAR
i: integer;
incondcomp: boolean;
PROCEDURE readbuffer;
(*READS A CHARACTER FROM THE INPUT BUFFER*)
PROCEDURE readline;
(*HANDLES LEADING BLANKS AND BLANK LINES, READS NEXT NONBLANK LINE
(WITHOUT LEADING BLANKS) INTO BUFFER*)
VAR
ch : char;
i: integer;
BEGIN (*READLINE*)
(*ENTERED AT THE BEGINNING OF A LINE*)
(*%ift trace *)
%trace('in readline ');\
(*%endc trace *)
LOOP
WHILE eoln (oldsource) AND NOT eof (oldsource) DO
BEGIN
(*IS THIS A PAGE MARK?*)
getlinenr (oldsource,linenb);
readln(oldsource);
IF linenb = ' ' THEN
BEGIN
newpage;
(*%IFT PCREF *)
SOURCEPAGE := SOURCEPAGE + 1;
SOURCELINE := 0;
(*%ENDC PCREF *)
END
ELSE (*HANDLE BLANK LINE*)
BEGIN
line500 := line500 + 1;
linecnt := linecnt + 1;
IF line500 = 500 THEN
BEGIN
line500 := 0;
write(tty,'(',linecnt:4,')');
break(tty);
END;
(*%IFT PCREF *)
IF (LINENB = '-----') AND COUNTING THEN
SOURCELINE := SOURCELINE + 1;
IF REALLINCNT = MAXLINE THEN
HEADER (CURPROCNAME);
REALLINCNT := REALLINCNT + 1;
if crossing then
WRITELN (CROSSLIST, CHR(HT),' ',LINECNT * INCREMENT : LINNUMSIZE);
(*%ELSE PCREF (IFF) *)
% writeln(newsource);\
(*%ENDC PCREF (ELSE) (IFF) *)
IF linecnt >= maxinc THEN
newpage;
END (*HANDLE BLANK LINE*);
END (*WHILE EOLN(OLDSOURCE)...*);
EXIT IF (oldsource↑ <> ' ') OR (eof (oldsource));
get(oldsource);
END (*LOOP*);
bufflen := 0;
(*READ IN THE LINE*)
WHILE NOT eoln (oldsource) DO
BEGIN
bufflen := bufflen + 1;
buffer [bufflen] := oldsource↑;
get(oldsource);
END;
IF bufflen > linsize THEN
BEGIN
error(linetoolong);
bufflen := linsize;
END
ELSE
BEGIN
buffer[bufflen+1] := ' '; (*SO WE CAN ALWAYS BE ONE CHAR AHEAD*)
buffer[bufflen+2] := ' ';
END;
IF NOT eof (oldsource) THEN
BEGIN
getlinenr (oldsource,linenb);
(*%IFT PCREF *)
IF COUNTING THEN
IF LINENB = '-----' THEN
SOURCELINE := SOURCELINE + 1
ELSE
BEGIN
SOURCELINE := 0;
FOR I := 1 TO 5 DO
SOURCELINE := SOURCELINE * 10 + ORD(LINENB[I]) - ORD('0');
END;
(*%ENDC PCREF *)
linecnt := linecnt + 1;
line500 := line500 + 1;
IF line500 = 500 THEN
BEGIN
line500 := 0;
write(tty,'(',linecnt:4,')');
break(tty);
END;
readln(oldsource);
END;
bufferptr := 1;
buffmark := 0;
notokenyet := true;
(*%ift trace *)
%trace('out readline ');\
(*%endc trace *)
END (*READLINE*) ;
BEGIN (*READBUFFER*)
(*IF READING PAST THE EXTRA BLANK ON THE END, GET A NEW LINE*)
IF eoline THEN
BEGIN
(*%IFT SAIL *)
IF skipping THEN
firstpage := false
ELSE
(*%ENDC SAIL *)
writeline (bufferptr);
ch := ' ';
IF eof (oldsource) THEN
eob := true
ELSE
readline;
END
ELSE
BEGIN
ch := buffer [bufferptr];
bufferptr := bufferptr + 1;
END;
eoline := bufferptr >= bufflen + 2;
END (*READBUFFER*) ;
FUNCTION resword: boolean ;
(*DETERMINES IF THE CURRENT IDENTIFIER IS A RESERVED WORD*)
VAR
i,j: integer;
local: boolean;
BEGIN (*RESWORD*)
local:= false;
i := resnum[sy[1]];
WHILE (i < resnum[succ(sy[1])]) AND NOT local DO
IF reslist[ i ] = sy THEN
BEGIN
local := true;
syty := ressy [i];
IF NOT rescase THEN
FOR j := bufferptr - syleng - 1 TO bufferptr - 2 DO
buffer[j] := lower[buffer[j]];
END
ELSE
i := i + 1;
resword := local;
END (*RESWORD*) ;
(*%IFT PCREF *)
PROCEDURE FINDNAME(CURPROC: LISTPTRTY);
VAR
LPTR: LISTPTRTY; (*ZEIGER AUF DEN VORGAENGER IM BAUM*)
ZPTR : LINEPTRTY; (*ZEIGER AUF DIE VORLETZTE ZEILENNUMMER IN EINER KETTE*)
FOUND, (*SET AFTER IDENTIFIER IS FOUND*)
RIGHT: BOOLEAN; (*MERKVARIABLE FUER DIE VERZWEIGUNG IM BAUM*)
INDEXCH : CHAR; (*INDEXVARIABLE FUER DAS FELD DER STARTZEIGER (FIRSTNAME)*)
BEGIN (*FINDNAME*)
INDEXCH := SY [1];
LISTPTR := FIRSTNAME [INDEXCH];
(*SEARCH IN THE TREE FOR THE IDENTIFIER*)
FOUND := FALSE;
WHILE NOT FOUND AND (LISTPTR <> NIL) DO
BEGIN
LPTR:= LISTPTR;
IF SY = LISTPTR↑.NAME THEN
BEGIN
FOUND := TRUE;
IF (LISTPTR↑.PROFUNFLAG IN ['P', 'F']) AND (NOT DECLARING) THEN
IF LOCPROCSTL↑.PROCLEVEL + 1 >= LISTPTR↑.PROCDATA↑.PROCLEVEL THEN
BEGIN
NEW (WORKCALL);
WORKCALL↑.WHOM := LISTPTR↑.PROCDATA;
WORKCALL↑.NEXTCALL := NIL;
END;
ZPTR := LISTPTR↑.LAST;
IF (ZPTR↑.LINENR <> LINECNT) OR (ZPTR↑.PAGENR <> PAGECNT) THEN
BEGIN
NEW (LISTPTR↑.LAST);
WITH LISTPTR↑.LAST↑ DO
BEGIN
LINENR := LINECNT;
PAGENR := PAGECNT;
CONTLINK := NIL;
IF DECLARING THEN
DECLFLAG := 'D'
ELSE
DECLFLAG := ' ';
END;
ZPTR↑.CONTLINK := LISTPTR↑.LAST;
END
ELSE
ZPTR↑.DECLFLAG := 'M';
END
ELSE
IF SY > LISTPTR↑.NAME THEN
BEGIN
LISTPTR:= LISTPTR↑.RLINK;
RIGHT:= TRUE;
END
ELSE
BEGIN
LISTPTR:= LISTPTR↑.LLINK;
RIGHT:= FALSE;
END;
END;
IF NOT FOUND THEN
BEGIN (*UNKNOWN IDENTIFIER*)
NEW (LISTPTR);
WITH LISTPTR↑ DO
BEGIN
NAME := SY;
LLINK := NIL;
RLINK := NIL;
PROFUNFLAG := ' ';
EXTERNFLAG := ' ';
PROCDATA := NIL;
END;
IF FIRSTNAME [INDEXCH] = NIL THEN
FIRSTNAME [INDEXCH] := LISTPTR
ELSE
IF RIGHT THEN
LPTR↑.RLINK := LISTPTR
ELSE
LPTR↑.LLINK := LISTPTR;
WITH LISTPTR↑ DO
BEGIN
NEW (FIRST);
WITH FIRST↑ DO
BEGIN
LINENR := LINECNT;
PAGENR := PAGECNT;
CONTLINK := NIL;
IF DECLARING THEN
DECLFLAG := 'D'
ELSE
DECLFLAG := ' ';
END;
LAST := FIRST ;
END;
END;
END (*FINDNAME*) ;
(*%ENDC PCREF *)
(*%IFT PCREF *)
PROCEDURE INSERTCALL;
VAR
LASTCALL,
THISCALL: CALLEDTY;
REPEATED : BOOLEAN; (*SET IF SY IS A PROC-NAME AND IS ALREADY IN THE CALL SEQUENCE*)
BEGIN (*INSERTCALL*)
IF LOCPROCSTL↑.FIRSTCALL = NIL THEN
LOCPROCSTL↑.FIRSTCALL := WORKCALL
ELSE
BEGIN
THISCALL := LOCPROCSTL↑.FIRSTCALL;
REPEATED := FALSE;
WHILE (THISCALL <> NIL) AND NOT REPEATED DO
IF THISCALL↑.WHOM↑.PROCNAME↑.NAME = WORKCALL↑.WHOM↑.PROCNAME↑.NAME THEN
REPEATED := TRUE
ELSE
BEGIN
LASTCALL := THISCALL;
THISCALL := THISCALL↑.NEXTCALL;
END;
IF NOT REPEATED THEN
LASTCALL↑.NEXTCALL := WORKCALL;
END;
WORKCALL := NIL;
END (*INSERTCALL*);
(*%ENDC PCREF *)
(*PARENTHESE,DOCOMMENT,SKIP_E_DIRECTORY*)
PROCEDURE parenthese (which: symbol);
(*HANDLES THE FORMATTING OF PARENTHESES, EXCEPT THOSE IN VARIANT PARTS OF RECORDS*)
VAR
oldspacesmark : integer; (*ALTER ZEICHENVORSCHUB BEI FORMATIERUNG VON KLAMMERN*)
BEGIN (*PARENTHESE*)
(*%ift trace *)
%trace('in parenthese ');\
(*%endc trace *)
oldspacesmark := spaces;
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := spaces;
END;
spaces := lastspaces + bufferptr - buffmark - 2;
(*%IFT PCREF *)
(*SKIP STUFF UNTIL WE SEEM TO BE OUT OF THE EXPRESSION*)
IF DECLARING THEN
REPEAT
INSYMBOL;
CASE SYTY OF
COLON: DECLARING := FALSE;
SEMICOLON: DECLARING := TRUE;
END;
UNTIL SYTY IN [WHICH,EXTERNSY..WHILESY,LABELSY..TYPESY,INITPROCSY..EXITSY,DOSY..FORWARDSY]
ELSE
(*%ENDC PCREF *)
REPEAT
insymbol;
UNTIL syty IN [which,externsy..whilesy,labelsy..typesy,initprocsy..exitsy,dosy..forwardsy];
spaces := oldspacesmark;
oldspaces := true;
IF syty = which THEN
insymbol
ELSE
IF which = rparent THEN
error(missgrpar)
ELSE
error(missgrbrack);
(*%ift trace *)
%trace('out parenthese ');\
(*%endc trace *)
END (*PARENTHESE*) ;
PROCEDURE docomment (dellength: integer; firstch: char);
VAR
oldspacesmark: integer;
BEGIN (* DOCOMMENT *)
(*%ift trace *)
%trace('in docomment ');\
(*%endc trace *)
oldspacesmark := spaces;
IF NOT oldspaces THEN
BEGIN
lastspaces := spaces;
oldspaces := true;
END;
spaces := spaces + bufferptr - 2;
IF dellength = 2 THEN
WHILE NOT ((ch = ')') AND (buffer[bufferptr-2] = '*')) DO
BEGIN
IF NOT comcase THEN
buffer[bufferptr] := lower[buffer[bufferptr]];
readbuffer;
END
ELSE
WHILE ch <> firstch DO
BEGIN
IF NOT comcase THEN
buffer[bufferptr] := lower[buffer[bufferptr]];
readbuffer;
END;
repeat
readbuffer;
until (ch <> ' ') or eoline;
if eoline and notokenyet then
readbuffer;
spaces := oldspacesmark;
(*%ift trace *)
%trace('out docomment ');\
(*%endc trace *)
END (*DOCOMMENT*);
(*%IFT SAIL *)
PROCEDURE skip_e_directory;
BEGIN (*SKIP_E_DIRECTORY*)
if not diring then
skipping := true;
WHILE pagecnt = 1 DO
readbuffer;
skipping := false;
END (*SKIP_E_DIRECTORY*);
(*%ENDC SAIL *)
(*] INSYMBOL*)
BEGIN (*INSYMBOL*)
(*%IFT PCREF *)
PREVSYTY := SYTY;
(*%ENDC PCREF *)
111:
syleng := 0;
(*%IFT SAIL *)
WHILE (ch IN ['_','(',' ','$','?','@','%',backslash,'"','#']) AND NOT eob DO
(*%ELSE SAIL (IFF) *)
% WHILE (CH IN ['_','(',' ','$','?','@','%',BACKSLASH,'!']) AND NOT EOB DO\
(*%ENDC SAIL (ELSE) (IFF) *)
CASE ch OF
'(':
BEGIN
readbuffer;
IF (ch = '*') THEN
docomment (2,'*')
ELSE
BEGIN
syty := lparent;
IF variant_level = 0 THEN
parenthese(rparent);
GOTO 1;
END;
END;
'%':
BEGIN
incondcomp := false;
readbuffer;
IF NOT anyversion THEN
WHILE ch IN digits DO
BEGIN
IF ord(ch) - ord('0') = goodversion THEN
incondcomp := true;
readbuffer;
END;
IF NOT (incondcomp OR anyversion) THEN
docomment (1,'\');
END;
(*%IFT SAIL *)
'"':
BEGIN
readbuffer;
docomment(1,'"');
END;
(*%ENDC SAIL *)
OTHERS:
readbuffer;
END;
CASE ch OF
'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I',
'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q',
'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y',
'Z':
BEGIN
syleng := 0;
sy := ' ';
REPEAT
syleng := syleng + 1;
IF syleng <= 10 THEN
sy [syleng] := ch;
readbuffer;
UNTIL NOT (ch IN (alphanum + ['_']));
(*%IFT SAIL *)
IF firstpage AND (sy = 'COMMENT ') THEN
BEGIN
skip_e_directory;
GOTO 111;
END
ELSE
(*%ENDC SAIL *)
IF NOT resword THEN
BEGIN
syty := ident ;
(*%IFT PCREF *)
FINDNAME(CURPROC);
(*%ENDC PCREF *)
IF NOT nonrcase THEN
FOR i := bufferptr - syleng - 1 TO bufferptr - 2 DO
buffer[i] := lower[buffer[i]];
END
END;
'0', '1', '2', '3', '4', '5', '6', '7', '8',
'9':
BEGIN
REPEAT
syleng := syleng + 1;
readbuffer;
UNTIL NOT (ch IN digits);
syty := intconst;
IF ch = 'B' THEN
readbuffer
ELSE
BEGIN
IF ch = '.' THEN
BEGIN
REPEAT
readbuffer
UNTIL NOT (ch IN digits);
syty := othersy; syleng := 0; (*REALS CAN'T BE LABELS*)
END;
IF ch = 'E' THEN
BEGIN
readbuffer;
IF ch IN ['+','-'] THEN
readbuffer;
WHILE ch IN digits DO
readbuffer;
syty := othersy; syleng := 0; (*REALS CAN'T BE LABELS*)
END;
END;
END;
'''':
BEGIN
syty := strgconst;
repeat
REPEAT
IF NOT strcase THEN
buffer[bufferptr] := lower[buffer[bufferptr]];
readbuffer;
UNTIL (ch = '''') OR eob OR eoline;
IF ch <> '''' THEN
error(missgquote);
readbuffer;
until ch <> '''';
END;
(*%IFT SAIL *)
'!':
(*%ELSE SAIL (IFF) *)
% '"': \
(*%ENDC SAIL (ELSE) (IFF) *)
BEGIN
REPEAT
readbuffer
UNTIL NOT (ch IN (digits + ['A'..'F']));
syty := intconst;
END;
' ': syty := eobsy; (*END OF FILE*)
':': BEGIN
readbuffer;
IF ch = '=' THEN
BEGIN
(*%IFT PCREF *)
WORKCALL := NIL;
(*%ENDC PCREF *)
syty := othersy;
readbuffer;
END
ELSE
syty := delsy[':'];
END;
'\':
BEGIN
readbuffer;
IF incondcomp THEN
BEGIN
incondcomp := false;
GOTO 111;
END
ELSE
syty := othersy;
END;
'[':
BEGIN
syty := lbracket; readbuffer; parenthese(rbracket);
END;
OTHERS:
BEGIN
syty := delsy [ch];
readbuffer;
END
END (*CASE CH OF*);
1:
notokenyet := false;
(*%IFT PCREF *)
IF WORKCALL <> NIL THEN
INSERTCALL;
(*%ENDC PCREF *)
END (*INSYMBOL*) ;
(*PARSING OF DECLARATIONS:*) (*RECDEF[CASEDEF,PARENTHESE]*)
PROCEDURE recdef;
VAR
oldspacesmark : integer; (*ALTER ZEICHENVORSCHUB BEI FORMATIERUNG VON RECORDS*)
PROCEDURE casedef;
VAR
oldspacesmark : integer; (*ALTER ZEICHENVORSCHUB BEI FORMATIERUNG VON VARIANT PARTS*)
PROCEDURE parenthese;
(*HANDLES THE FORMATTING OF PARENTHESES INSIDE VARIANT PARTS*)
VAR
oldspacesmark : integer; (*SAVED VALUE OF 'SPACES'*)
BEGIN (*PARENTHESE*)
(*%ift trace *)
%trace('in parenthese-r');\
(*%endc trace *)
oldspacesmark := spaces;
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := spaces;
END;
spaces := spaces + bufferptr - 2;
(*%IFT PCREF *)
DECLARING := TRUE;
(*%ENDC PCREF *)
insymbol;
REPEAT
CASE syty OF
casesy :
casedef;
recordsy :
recdef;
(*%IFT PCREF *)
SEMICOLON, LPARENT:
BEGIN
DECLARING := TRUE;
INSYMBOL;
END;
EQLSY, COLON:
BEGIN
DECLARING := FALSE;
INSYMBOL;
END;
(*%ENDC PCREF *)
rparent: ;
OTHERS :
insymbol;
END;
(*UNTIL WE APPARENTLY LEAVE THE DECLARATION*)
UNTIL syty IN [strgconst..whilesy,rparent,labelsy..exitsy,dosy..beginsy,
loopsy..ifsy,forwardsy];
spaces := oldspacesmark;
oldspaces := true;
IF syty = rparent THEN
BEGIN
(*%IFT PCREF *)
DECLARING := TRUE;
(*%ENDC PCREF *)
insymbol;
END
ELSE
error(missgrpar);
(*%ift trace *)
%trace('out parenthese-');\
(*%endc trace *)
END (*PARENTHESE*) ;
BEGIN (*CASEDEF*)
(*%ift trace *)
%trace('in casedef ');\
(*%endc trace *)
variant_level := variant_level+1;
oldspacesmark := spaces;
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := spaces;
END;
spaces := bufferptr - buffmark + lastspaces - syleng + 3;
(*%IFT PCREF *)
DECLARING := TRUE;
(*%ENDC PCREF *)
insymbol;
(*%IFT PCREF *)
DECLARING := FALSE;
(*%ENDC PCREF *)
REPEAT
IF syty = lparent THEN
parenthese
ELSE
insymbol
UNTIL syty IN [untilsy..exitsy,labelsy..endsy,rparent,dosy..beginsy];
spaces := oldspacesmark;
variant_level := variant_level-1;
(*%ift trace *)
%trace('out casedef ');\
(*%endc trace *)
END (*CASEDEF*) ;
BEGIN (*RECDEF*)
(*%ift trace *)
%trace('in recdef ');\
(*%endc trace *)
oldspacesmark := spaces;
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := spaces;
END;
spaces := bufferptr - buffmark + spaces - syleng - 2 + feed;
(*%IFT PCREF *)
DECLARING := TRUE;
(*%ENDC PCREF *)
insymbol;
REPEAT
CASE syty OF
casesy : casedef;
recordsy : recdef;
(*%IFT PCREF *)
SEMICOLON, LPARENT:
BEGIN
DECLARING := TRUE;
INSYMBOL;
END;
EQLSY, COLON:
BEGIN
DECLARING := FALSE;
INSYMBOL;
END;
ENDSY:;
(*%ENDC PCREF *)
OTHERS : insymbol
END;
UNTIL syty IN [untilsy..exitsy,labelsy..endsy,dosy..beginsy];
oldspaces := true;
lastspaces := spaces - feed;
spaces := oldspacesmark;
IF syty = endsy THEN
BEGIN
(*%IFT PCREF *)
DECLARING := TRUE;
(*%ENDC PCREF *)
insymbol;
END
ELSE
error(missgend);
(*%ift trace *)
%trace('out recdef ');\
(*%endc trace *)
END (*RECDEF*) ;
(*PARSING OF STATEMENTS:*) (*STATEMENT[endedstats,compstat,casestat,loopstat,ifstat,labelstat,repeatstat]*)
PROCEDURE statement;
VAR
oldspacesmark, (*SPACES AT ENTRY OF THIS PROCEDURE*)
curblocknr : integer; (*CURRENT BLOCKNUMBER*)
PROCEDURE endedstatseq(endsym: symbol; letter: char);
BEGIN
(*%ift trace *)
%trace('in endedstatseq');\
(*%endc trace *)
statement;
WHILE syty = semicolon DO
BEGIN
insymbol;
statement;
END;
WHILE NOT (syty IN [endsym,eobsy,proceduresy,functionsy]) DO
BEGIN
error(missgend);
IF NOT (syty IN begsym) THEN
insymbol;
statement;
WHILE syty = semicolon DO
BEGIN
insymbol;
statement;
END;
END;
IF forcing THEN
writeline(bufferptr-syleng);
(*%IFT PCREF *)
EMARKTEXT := LETTER;
EMARKNR := CURBLOCKNR;
(*%ENDC PCREF *)
oldspaces := true;
IF (endsym = endsy) THEN
BEGIN
IF indentbegin = 0 THEN
lastspaces := max(0,spaces-begexd)
ELSE
lastspaces := max(0,spaces-indentbegin);
IF syty <> endsy THEN
error(missgend)
END
ELSE
BEGIN
lastspaces := max(0,spaces - feed);
IF syty <> endsym THEN
error(missguntil);
END;
(*%ift trace *)
%trace('out endedstatse');\
(*%endc trace *)
END (*ENDEDSTATSEQ*);
PROCEDURE compstat;
BEGIN (*COMPSTAT*)
(*%ift trace *)
%trace('in compstat ');\
(*%endc trace *)
IF indentbegin = 0 THEN
BEGIN
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := max (0,spaces-begexd)
END;
END
ELSE
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := max (0,spaces - indentbegin);
END;
(*%IFT PCREF *)
BMARKTEXT := 'B';
MARKSYTY := PREVSYTY;
insymbol;
IF forcing THEN
BEGIN
IF MARKSYTY = OTHERSY THEN
nocountyet := TRUE;
WRITELINE(BUFFERPTR-SYLENG);
END;
(*%ELSE PCREF (IFF) *)
% insymbol;\
% IF forcing THEN\
% writeline(bufferptr-syleng);\
(*%ENDC PCREF (ELSE) (IFF) *)
endedstatseq(endsy, 'E');
IF syty = endsy THEN
BEGIN
insymbol ;
(*%IFT PCREF *)
IF FORCING THEN
(*%ENDC PCREF *)
writeline(bufferptr-syleng);
END;
(*%ift trace *)
%trace('out compstat ');\
(*%endc trace *)
END (*COMPSTAT*) ;
PROCEDURE casestat;
VAR
oldspacesmark : integer; (*SAVED VALUE OF 'SPACES'*)
BEGIN (*CASESTAT*)
(*%ift trace *)
%trace('in casestat ');\
(*%endc trace *)
(*%IFT PCREF *)
BMARKTEXT := 'C';
(*%ENDC PCREF *)
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := max (0,spaces-feed);
END;
insymbol;
statement;
IF syty = ofsy THEN
(*%IFT PCREF *)
BEGIN
IF FORCING THEN
WRITELINE (BUFFERPTR)
END
(*%ELSE PCREF (IFF) *)
% writeline (bufferptr)\
(*%ENDC PCREF (ELSE) (IFF) *)
ELSE
error (missgof);
LOOP
REPEAT
REPEAT
insymbol;
UNTIL syty IN [colon, functionsy .. eobsy];
IF syty = colon THEN
BEGIN
oldspacesmark := spaces;
lastspaces := spaces;
spaces := spaces + feed;
(* SPACES := BUFFERPTR - BUFFMARK + SPACES - 4; *)
oldspaces := true;
thendo := true;
insymbol;
statement;
IF syty = semicolon THEN
insymbol;
spaces := oldspacesmark;
END;
UNTIL syty IN endsym;
EXIT IF syty IN [endsy,eobsy,proceduresy,functionsy];
error (missgend);
END;
(*%IFT PCREF *)
IF FORCING THEN
writeline(bufferptr-syleng);
EMARKTEXT := 'E';
EMARKNR := CURBLOCKNR;
IF syty = endsy THEN
BEGIN
insymbol ;
IF FORCING THEN
(*%ELSE PCREF (IFF) *)
% writeline(bufferptr-syleng);\
% IF syty = endsy THEN\
% BEGIN\
% insymbol ;\
(*%ENDC PCREF (ELSE) (IFF) *)
writeline(bufferptr-syleng);
END
ELSE
error (missgend);
(*%ift trace *)
%trace('out casestat ');\
(*%endc trace *)
END (*CASESTAT*) ;
PROCEDURE loopstat;
BEGIN (*LOOPSTAT*)
(*%ift trace *)
%trace('in loopstat ');\
(*%endc trace *)
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := max (0,spaces - feed);
END;
(*%IFT PCREF *)
BMARKTEXT := 'L';
MARKSYTY := PREVSYTY;
INSYMBOL;
IF FORCING THEN
BEGIN
IF NOT (MARKSYTY IN OPENBLOCKSYM) THEN
nocountyet := TRUE;
WRITELINE(BUFFERPTR-SYLENG);
END;
(*%ELSE PCREF (IFF) *)
% insymbol;\
(*%ENDC PCREF (ELSE) (IFF) *)
statement;
WHILE syty = semicolon DO
BEGIN
insymbol;
statement;
END;
IF syty = exitsy THEN
BEGIN
(*%IFT PCREF *)
IF FORCING THEN
writeline(bufferptr-syleng);
oldspaces := true;
lastspaces := spaces-feed;
EMARKTEXT := 'X';
EMARKNR := CURBLOCKNR;
INSYMBOL; INSYMBOL;
PREVSYTY := EXITSY;
(*%ELSE PCREF (IFF) *)
% writeline(bufferptr-syleng);\
% oldspaces := true;\
% lastspaces := spaces-feed;\
% insymbol; insymbol;\
(*%ENDC PCREF (ELSE) (IFF) *)
END
ELSE
error(missgexit);
endedstatseq(endsy, 'E');
IF syty = endsy THEN
BEGIN
insymbol ;
(*%IFT PCREF *)
IF FORCING THEN
(*%ENDC PCREF *)
writeline(bufferptr-syleng);
END;
(*%ift trace *)
%trace('out loopstat ');\
(*%endc trace *)
END (*LOOPSTAT*) ;
PROCEDURE ifstat;
VAR
oldspacesmark: integer;
BEGIN (*IFSTAT*)
(*%ift trace *)
%trace('in ifstat ');\
(*%endc trace *)
oldspacesmark := spaces;
(*%IFT PCREF *)
MARKSYTY := PREVSYTY;
BMARKTEXT := 'I';
(*%ENDC PCREF *)
if not elsehere then
begin
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := max (0,spaces - feed);
END;
(*MAKE 'THEN' AND 'ELSE' LINE UP WITH 'IF' UNLESS ON SAME LINE*)
spaces := lastspaces + bufferptr - buffmark + feed - 4;
end (*if not elsehere*);
insymbol;
statement; (*WILL EAT THE EXPRESSION AND STOP ON A KEYWORD*)
IF syty = thensy THEN
BEGIN
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := max (0,spaces-feed);
END;
(*%IFT PCREF *)
EMARKTEXT := 'T';
EMARKNR := CURBLOCKNR;
IF forcing THEN
BEGIN
IF NOT (MARKSYTY IN OPENBLOCKSYM) THEN
nocountyet := TRUE;
WRITELINE(BUFFERPTR);
END
(*%ELSE PCREF (IFF) *)
% IF forcing THEN\
% writeline(bufferptr)\
(*%ENDC PCREF (ELSE) (IFF) *)
ELSE
thendo := true;
(*SUPPRESS FURTHER INDENTATION FROM A 'DO'*)
insymbol;
statement;
END
ELSE
error (missgthen);
IF syty = elsesy THEN (*PARSE THE ELSE PART*)
BEGIN
(*%IFT PCREF *)
IF FORCING THEN
writeline(bufferptr-syleng);
EMARKTEXT := 'S';
EMARKNR := CURBLOCKNR;
(*%ELSE PCREF (IFF) *)
% writeline(bufferptr-syleng);\
(*%ENDC PCREF (ELSE) (IFF) *)
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := max (0,spaces-feed);
END;
IF forcing and not elseifing THEN
(*%IFT PCREF *)
BEGIN
nocountyet := TRUE;
WRITELINE(BUFFERPTR);
END
(*%ELSE PCREF (IFF) *)
% writeline(bufferptr)\
(*%ENDC PCREF (ELSE) (IFF) *)
ELSE
thendo := true;
elsehere := true;
insymbol;
statement;
END;
oldspaces := true; (*PRESERVE INDENTATION OF STATEMENT*)
writeline(bufferptr-syleng);
spaces := oldspacesmark;
(*%ift trace *)
%trace('out ifstat ');\
(*%endc trace *)
END (*IFSTAT*) ;
PROCEDURE labelstat;
BEGIN (*LABELSTAT*)
lastspaces := level * feed;
oldspaces := true;
insymbol;
(*%IFT PCREF *)
IF FORCING THEN
BEGIN
nocountyet := TRUE;
WRITELINE(BUFFERPTR-SYLENG);
END;
(*%ELSE PCREF (IFF) *)
% writeline(bufferptr-syleng);\
(*%ENDC PCREF (ELSE) (IFF) *)
END (*LABELSTAT*) ;
PROCEDURE repeatstat;
BEGIN
(*%ift trace *)
%trace('in repeatstat ');\
(*%endc trace *)
(*%IFT PCREF *)
BMARKTEXT := 'R';
MARKSYTY :=PREVSYTY;
IF NOT (MARKSYTY IN OPENBLOCKSYM) THEN
nocountyet := TRUE;
(*%ENDC PCREF *)
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := max (0,spaces - feed);
END;
insymbol;
endedstatseq(untilsy, 'U');
IF syty = untilsy THEN
BEGIN
insymbol;
statement;
(*%IFT PCREF *)
IF FORCING THEN
(*%ENDC PCREF *)
writeline(bufferptr-syleng);
END;
(*%ift trace *)
%trace('out repeatstat ');\
(*%endc trace *)
END (*REPEATSTAT*) ;
BEGIN (*STATEMENT*)
(*%ift trace *)
%trace('in statement ');\
(*%endc trace *)
oldspacesmark := spaces; (*SAVE THE INCOMING VALUE OF SPACES TO BE ABLE TO RESTORE IT*)
IF syty = intconst THEN
BEGIN
insymbol;
IF syty = colon THEN
labelstat;
END;
IF syty IN begsym THEN
BEGIN
(*%IFT PCREF *)
BLOCKNR := (BLOCKNR + 1) MOD 1000;
CURBLOCKNR := BLOCKNR;
BMARKNR := CURBLOCKNR;
(*%ENDC PCREF *)
IF NOT thendo THEN
BEGIN
(*%IFT PCREF *)
IF FORCING THEN
(*%ENDC PCREF *)
writeline(bufferptr-syleng);
IF (syty <> beginsy) THEN
spaces := spaces + feed
ELSE
spaces:=spaces + indentbegin;
END;
CASE syty OF
beginsy : compstat;
loopsy : loopstat;
casesy : casestat;
ifsy : ifstat;
repeatsy: repeatstat
END;
END
ELSE
BEGIN
IF forcing THEN
IF syty IN [forsy,whilesy] THEN
writeline(bufferptr-syleng);
(*%IFT PCREF *)
IF SYTY = GOTOSY THEN
GOTOINLINE:=TRUE;
(*%ENDC PCREF *)
WHILE NOT (syty IN [semicolon,functionsy..recordsy]) DO
insymbol;
IF syty = dosy THEN
BEGIN
IF NOT thendo THEN
BEGIN
oldspaces := true;
lastspaces := spaces;
spaces := spaces + feed;
IF NOT forcing THEN
thendo := true;
END;
insymbol;
statement;
writeline(bufferptr-syleng);
END;
END;
spaces := oldspacesmark;
(*%ift trace *)
%trace('out statement ');\
(*%endc trace *)
END (*STATEMENT*) ;
(*]BLOCK*)
BEGIN (*BLOCK*)
(*%ift trace *)
%trace('in block ');\
(*%endc trace *)
(*%IFT PCREF *)
STMTPART := FALSE;
DECLARING := TRUE;
(*%ENDC PCREF *)
REPEAT
insymbol;
UNTIL syty IN relevantsym;
level := level + 1;
spaces := level * feed;
(*%IFT PCREF *)
(*HANDLE NESTING LIST*)
CURPROC := LISTPTR;
LOCPROCSTL := PROCSTRUCF;
WITH PROCSTRUCDATA, ITEM DO
IF EXISTS THEN
WITH PROCNAME↑ DO
BEGIN
IF PROCDATA <> NIL THEN
BEGIN
IF EXTERNFLAG = 'F' THEN
PROCDATA := NIL
ELSE
IF EXTERNFLAG = ' ' THEN
EXTERNFLAG := 'D';
LOCPROCSTL := PROCDATA;
END;
IF PROCDATA = NIL THEN
BEGIN
IF (SYTY IN [FORWARDSY,EXTERNSY]) THEN
IF SYTY = EXTERNSY THEN
EXTERNFLAG := 'E'
ELSE
EXTERNFLAG := 'F';
NEW(PROCSTRUCL↑.NEXTPROC);
PROCSTRUCL := PROCSTRUCL↑.NEXTPROC;
PROCDATA := PROCSTRUCL;
PROCSTRUCL↑ := ITEM;
LOCPROCSTL := PROCSTRUCL;
END;
PROCSTRUCDATA.EXISTS := FALSE
END;
(*%ENDC PCREF *)
REPEAT
fwddecl := false;
WHILE syty IN decsym DO (*DECLARATIONS: LABELS, TYPES, VARS*)
BEGIN
(*%IFT PCREF *)
IF FORCING THEN
(*%ENDC PCREF *)
writeline(bufferptr-syleng);
oldspaces := true;
lastspaces := max(0,spaces-feed);
IF syty = programsy THEN
BEGIN
programpresent := true;
insymbol;
prog_name := sy;
(*%IFT PCREF *)
PROCSTRUCF↑.PROCNAME := LISTPTR;
LISTPTR↑.PROCDATA := PROCSTRUCF;
LISTPTR↑.PROFUNFLAG := 'M';
DECLARING := FALSE;
(*%ENDC PCREF *)
writeln(tty);
write(tty,version:verlength,': ',old_name:6,' [ ',prog_name,' ] PAGE');
FOR i := 1 TO pagecnt DO
write (tty, i:3,'..');
break(tty);
END
ELSE (*SYTY <> PROGRAMSY*)
BEGIN
(*%IFT PCREF *)
DECLARING := TRUE;
(*%ENDC PCREF *)
IF forcing THEN
writeline(bufferptr);
END (*SYTY <> PROGRAMSY*);
(*%IFT PCREF *)
REPEAT
INSYMBOL;
CASE SYTY OF
SEMICOLON, LPARENT : DECLARING := TRUE;
EQLSY, COLON : DECLARING := FALSE;
RECORDSY: RECDEF;
END;
IF SYTY = RECORDSY THEN
RECDEF;
UNTIL SYTY IN RELEVANTSYM;
END;
DECLARING := FALSE;
WHILE SYTY IN PROSYM DO (*PROCEDURE AND FUNCTION DECLARATIONS*)
BEGIN
IF FORCING THEN
WRITELINE(BUFFERPTR-SYLENG);
OLDSPACES := TRUE;
LASTSPACES := MAX(0,SPACES-FEED);
LASTPROCNAME := CURPROCNAME;
IF SYTY <> INITPROCSY THEN
BEGIN
ITISAPROC := SYTY = PROCEDURESY;
DECLARING := TRUE;
INSYMBOL;
CURPROCNAME := LISTPTR↑.NAME;
IF ITISAPROC THEN
LISTPTR↑.PROFUNFLAG := 'P'
ELSE
LISTPTR↑.PROFUNFLAG := 'F';
WITH PROCSTRUCDATA, ITEM DO
BEGIN
EXISTS := TRUE;
PROCNAME := LISTPTR;
NEXTPROC := NIL;
LINENR := LINECNT;
PAGENR := PAGECNT;
PROCLEVEL := LEVEL;
PRINTED := FALSE;
FIRSTCALL := NIL;
END;
END
ELSE
CURPROCNAME := 'INITPROCED';
BLOCK;
CURPROCNAME := LASTPROCNAME;
DECLARING := FALSE;
STMTPART := FALSE;
IF SYTY = SEMICOLON THEN
INSYMBOL;
END (*WHILE SYTY IN PROSYM*)
(*%ELSE PCREF (IFF) *)
% REPEAT\
% insymbol;\
% IF syty = recordsy THEN\
% recdef;\
% UNTIL syty IN relevantsym;\
% END;\
% WHILE syty IN prosym DO (*PROCEDURE AND FUNCTION DECLARATIONS*)\
% BEGIN\
% writeline(bufferptr-syleng);\
% oldspaces := true;\
% lastspaces := max(0,spaces-feed);\
% IF syty <> initprocsy THEN\
% insymbol;\
% block;\
% IF syty = semicolon THEN\
% insymbol;\
% END (*WHILE SYTY IN PROSYM*)\
(*%ENDC PCREF (ELSE) (IFF) *)
(*FORWARD AND EXTERNAL DECLARATIONS MAY COME BEFORE 'VAR', ETC.*)
UNTIL NOT fwddecl;
IF forcing THEN
writeline(bufferptr-syleng);
level := level - 1;
spaces := level * feed;
IF NOT (syty IN [beginsy,forwardsy,externsy,eobsy,langsy]) THEN
BEGIN
IF (level = 0) AND (syty = point) THEN
nobody := true
ELSE
error (begerrinblkstr);
WHILE NOT (syty IN [beginsy,forwardsy,externsy,eobsy,langsy,point]) DO
insymbol
END;
IF syty = beginsy THEN
(*%IFT PCREF *)
BEGIN
COUNTLINE := SOURCELINE; (*TO GET THE COUNT IN THE LINE OF THE BEGIN*)
COUNTPAGE := SOURCEPAGE;
DECLARING := FALSE;
STMTPART := TRUE; (*TO PREVENT BARS IN DECLARATIONS*)
LOCPROCSTL↑.BEGLINE := LINECNT + 1;
LOCPROCSTL↑.BEGPAGE := PAGECNT;
STATEMENT;
LOCPROCSTL↑.ENDLINE := LINECNT + 1;
LOCPROCSTL↑.ENDPAGE := PAGECNT;
END
(*%ELSE PCREF (IFF) *)
% statement\
(*%ENDC PCREF (ELSE) (IFF) *)
ELSE
IF NOT nobody THEN
BEGIN
fwddecl := true;
insymbol;
END;
IF level = 0 THEN
IF programpresent THEN
BEGIN
IF nobody THEN
BEGIN
error (missgmain);
errcount := errcount - 1;
END;
IF syty <> point THEN
error(missgpoint);
writeline(bufflen+2);
writeln(tty);
writeln (tty,errcount:4,' ERROR(S) DETECTED'); break(tty);
(*%ift trace *)
%trace('out block ');\
(*%endc trace *)
END (*IF LEVEL = 0*);
END (*BLOCK*) ;
(*cross references:*) (*PRINT_XREF_LIST[CHECKPAGE,WRITEPROCNAME,WRITELINENR,DUMPCALL]*)
(*%IFT PCREF *)
PROCEDURE PRINT_XREF_LIST;
VAR
PRED : LISTPTRTY;
INDEXCH : CHAR; (*LAUFVARIABLE FUER DAS FELD 'FIRSTNAME' ZUM AUSDRUCKEN*)
LISTPGNR : BOOLEAN; (*TRUE IF THE SOURCE CONTAINS A PAGE MARK*)
ITEMLEN: INTEGER; (*LENGTH OF A PRINTED LINENUMBER, 9 OR 12*)
THISCALL : CALLEDTY;
OLDCROSSING: BOOLEAN;
PROCEDURE CHECKPAGE(HEADING: BOOLEAN);
BEGIN
IF REALLINCNT = MAXLINE THEN
BEGIN
IF HEADING THEN
HEADER (LISTPTR↑.NAME)
ELSE
HEADER (BLANKS);
END;
REALLINCNT:=REALLINCNT+1;
END(*CHECKPAGE*);
PROCEDURE WRITEPROCNAME (PROCSTRUCL: PROCSTRUCTY; DEPTH: INTEGER; MARK: CHAR; NUMBERING: BOOLEAN);
BEGIN (*WRITEPROCNAME*)
WRITELN(CROSSLIST);
CHECKPAGE(FALSE);
WITH PROCSTRUCL↑, PROCNAME↑ DO
BEGIN
IF NUMBERING THEN
WRITE (CROSSLIST, LINECNT * INCREMENT:LINNUMSIZE+1, ' ');
IF DEPTH > 2 THEN
WRITE (CROSSLIST, '. ',DOTS:DEPTH-1)
ELSE
WRITE (CROSSLIST, '.':DEPTH+1);
WRITE (CROSSLIST, NAME : 10, ' (', PROFUNFLAG, ')',
MARK:2, EXTERNFLAG:2, CHR(HT), LINENR * INCREMENT : 8);
IF LISTPGNR OR (PAGENR > 1) THEN
WRITE(CROSSLIST, '/',PAGENR : 2);
IF (MARK = ' ') AND NOT (EXTERNFLAG IN ['E', 'F']) THEN
BEGIN
WRITE (CROSSLIST, BEGLINE * INCREMENT: LINNUMSIZE + 3);
IF LISTPGNR THEN
WRITE (CROSSLIST, '/', BEGPAGE: 2);
WRITE (CROSSLIST, ENDLINE * INCREMENT: LINNUMSIZE + 3);
IF LISTPGNR THEN
WRITE (CROSSLIST, '/', ENDPAGE:2);
END
ELSE
IF EXTERNFLAG = 'F' THEN
EXTERNFLAG := ' ';
END;
END (*WRITEPROCNAME*);
PROCEDURE WRITELINENR (SPACES : INTEGER);
VAR
LINK : LINEPTRTY; (*ZEIGER ZUM DURCHHANGELN DURCH DIE VERKETTUNG DER ZEILENNUMMERN*)
MAXCNT, (*MAXIMUM ALLOWABLE VALUE OF COUNT*)
COUNT : INTEGER; (*ZAEHLT DIE GEDRUCKTEN ZEILENNUMMERN PRO ZEILE*)
BEGIN (*WRITELINENR*)
COUNT := 0;
MAXCNT := (MAXCROSSCH + 1 - SPACES) DIV ITEMLEN; (*ITEMS ARE ITEMLEN CHARS EACH*)
LINK := LISTPTR↑.FIRST;
REPEAT
IF COUNT = MAXCNT THEN
BEGIN
WRITELN(CROSSLIST);
CHECKPAGE(TRUE);
WRITE (CROSSLIST, ' ' : SPACES);
COUNT := 0;
END;
COUNT := COUNT + 1;
WITH LINK↑ DO
BEGIN
WRITE (CROSSLIST, LINENR * INCREMENT : LINNUMSIZE + 1);
IF LISTPGNR THEN
WRITE(CROSSLIST, '/',PAGENR : 2);
WRITE (CROSSLIST,DECLFLAG);
LINK := CONTLINK;
END;
UNTIL LINK = NIL;
END (*WRITELINENR*) ;
PROCEDURE DUMPCALL (THISPROC: PROCSTRUCTY; DEPTH: INTEGER);
VAR
THISCALL: CALLEDTY;
BEGIN (*DUMPCALL*)
LINECNT := LINECNT + 1;
WITH THISPROC↑ DO
IF PRINTED THEN
WRITEPROCNAME (THISPROC, DEPTH,'*', TRUE)
ELSE
BEGIN
WRITEPROCNAME (THISPROC, DEPTH, ' ', TRUE);
PRINTED := TRUE;
LINENR := LINECNT;
PAGENR := PAGECNT;
THISCALL := FIRSTCALL;
WHILE THISCALL <> NIL DO
BEGIN
DUMPCALL (THISCALL↑.WHOM, DEPTH + FEED);
THISCALL := THISCALL↑.NEXTCALL;
END;
END;
END (*DUMPCALL*);
BEGIN (*PRINT_XREF_LIST*)
OLDCROSSING := CROSSING;
CROSSING := TRUE;
LISTPGNR := PAGECNT > 1;
ITEMLEN := LINNUMSIZE + 2;
IF LISTPGNR THEN
ITEMLEN := ITEMLEN + 3;
WITH FIRSTNAME ['M']↑ DO (*DELETE 'MAIN'*)
IF RLINK = NIL THEN
FIRSTNAME ['M'] := LLINK
ELSE
BEGIN
LISTPTR := RLINK;
WHILE LISTPTR↑.LLINK <> NIL DO
LISTPTR := LISTPTR↑.LLINK;
LISTPTR↑.LLINK := LLINK;
FIRSTNAME ['M'] := RLINK;
END;
INDEXCH := 'A';
WHILE (INDEXCH < 'Z') AND (FIRSTNAME [INDEXCH] = NIL) DO
INDEXCH := SUCC (INDEXCH);
IF FIRSTNAME [INDEXCH] <> NIL THEN
BEGIN
IF REFING THEN
BEGIN
PAGECNT := PAGECNT + 1;
PAGECNT2 := 0;
HEADER (BLANKS);
WRITELN (CROSSLIST, 'CROSS REFERENCE LISTING OF IDENTIFIERS');
WRITELN (CROSSLIST, '**************************************');
WRITE(TTY,'CROSS REFERENCE..'); BREAK;
REALLINCNT:= REALLINCNT + 3;
FOR INDEXCH := INDEXCH TO 'Z' DO
WHILE FIRSTNAME [INDEXCH] <> NIL DO
BEGIN
LISTPTR := FIRSTNAME [INDEXCH];
WHILE LISTPTR↑.LLINK <> NIL DO
BEGIN
PRED := LISTPTR;
LISTPTR := LISTPTR↑.LLINK;
END;
IF LISTPTR = FIRSTNAME [INDEXCH] THEN
FIRSTNAME [INDEXCH] := LISTPTR↑.RLINK
ELSE
PRED↑.LLINK := LISTPTR↑.RLINK;
WRITELN(CROSSLIST);
CHECKPAGE(TRUE);
WRITE (CROSSLIST, LISTPTR↑.PROFUNFLAG, LISTPTR↑.NAME : 11);
WRITELINENR (12);
END;
END;
IF PROCSTRUCL <> PROCSTRUCF THEN
BEGIN
IF DECNESTING THEN
BEGIN
PAGECNT := PAGECNT + 1;
PAGECNT2 := 0;
WRITELN (CROSSLIST);
HEADER ('*DECLARAT*');
WRITELN (CROSSLIST, 'NESTING OF PROCEDURE-FUNCTION DECLARATION');
WRITELN (CROSSLIST, '*****************************************');
WRITELN (CROSSLIST, 'NAME, P/F, HEADERLINE, BEGINLINE, ENDLINE');
WRITE(TTY,' PROCEDURE DECLARATIONS..'); BREAK;
REALLINCNT:= REALLINCNT + 4;
PROCSTRUCL := PROCSTRUCF;
REPEAT
WRITEPROCNAME (PROCSTRUCL, PROCSTRUCL↑.PROCLEVEL * 4, ' ', FALSE);
PROCSTRUCL := PROCSTRUCL↑.NEXTPROC;
UNTIL PROCSTRUCL = NIL;
END;
IF CALLNESTING THEN
BEGIN
PAGECNT := PAGECNT + 1;
PAGECNT2 := 0;
WRITELN (CROSSLIST);
HEADER ('* CALLS * ');
WRITELN (CROSSLIST, 'NESTING OF PROCEDURE-FUNCTION CALLS');
WRITELN (CROSSLIST, '***********************************');
WRITELN (CROSSLIST, 'NAME, P/F, HEADERLINE, BEGINLINE, ENDLINE');
WRITE(TTY,' PROCEDURE CALLS..'); BREAK;
REALLINCNT := REALLINCNT + 4;
LINECNT := 0;
PROCSTRUCL := PROCSTRUCF;
WHILE PROCSTRUCL <> NIL DO
BEGIN
IF NOT PROCSTRUCL↑.PRINTED THEN
DUMPCALL (PROCSTRUCL, 0);
PROCSTRUCL := PROCSTRUCL↑.NEXTPROC;
END;
END;
END;
END;
CROSSING := OLDCROSSING;
END (*PRINT_XREF_LIST*) ;
(*%ENDC PCREF *)
(*MAIN PROGRAM*)
BEGIN
settime;
getdirectives;
initialize;
(*FIND MAX POSSIBLE LINE NUMBER WITH THIS INCREMENT*)
(*%IFT SAIL *)
maxinc := (1000 DIV increment);
(*%else sail (IFF) *)
%MAXINC := (99999 DIV INCREMENT);\
%IF MAXINC > 4000 THEN\
% MAXINC := 4000;\
(*%endc sail (ELSE) (IFF) *)
LOOP
block;
EXIT IF NOT programpresent OR (syty = eobsy);
(*%IFT PCREF *)
IF COUNTING THEN
BEGIN
WRITELN(TTY);
WRITELN(TTY,'MAXIMUM COUNT: ',MAXCOUNTTIMES,' AT LINE ',MAXCOUNTLINE*INCREMENT:5,'/',MAXCOUNTPAGE:2);
IF CROSSING THEN
BEGIN
WRITELN(CROSSLIST);
WRITELN(CROSSLIST,'MAXIMUM COUNT: ',MAXCOUNTTIMES,' AT LINE ',MAXCOUNTLINE*INCREMENT:5,'/',MAXCOUNTPAGE:2);
END;
END;
IF REFING OR DECNESTING OR CALLNESTING THEN
PRINT_XREF_LIST;
DISPOSE(HEAPMARK); (*RELEASE THE ENTIRE HEAP*)
(*%ENDC PCREF *)
reinitialize;
END;
(*%IFT PCREF *)
IF COUNTING THEN
REWRITE(COUNTFILE);
GETNEXTCALL (LINK_NAME, LINK_DEVICE);
(*%ENDC PCREF *)
timereport(ttyoutput, ' ');
(*%IFT PCREF *)
IF LINK_NAME <> ' ' THEN
CALL (LINK_NAME, LINK_DEVICE);
(*%ENDC PCREF *)
END (*PCROSS*).